Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
160
Issues
160
List
Board
Labels
Milestones
Merge Requests
14
Merge Requests
14
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
5d5300cd
Commit
5d5300cd
authored
Sep 21, 2023
by
Alexandre Delanoë
2
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[CLEAN] return -> pure to make hlint happier
parent
8b1b7d15
Changes
38
Hide whitespace changes
Inline
Side-by-side
Showing
38 changed files
with
104 additions
and
104 deletions
+104
-104
API.hs
src/Gargantext/API.hs
+3
-3
EKG.hs
src/Gargantext/API/EKG.hs
+1
-1
List.hs
src/Gargantext/API/Ngrams/List.hs
+2
-2
Types.hs
src/Gargantext/API/Ngrams/Types.hs
+2
-2
Types.hs
src/Gargantext/API/Node/Corpus/Types.hs
+1
-1
Share.hs
src/Gargantext/API/Node/Share.hs
+1
-1
MaxClique.hs
src/Gargantext/Core/Methods/Graph/MaxClique.hs
+4
-4
NodeStory.hs
src/Gargantext/Core/NodeStory.hs
+1
-1
Parsec.hs
src/Gargantext/Core/Text/Corpus/Parsers/Date/Parsec.hs
+5
-5
Iramuteq.hs
src/Gargantext/Core/Text/Corpus/Parsers/Iramuteq.hs
+1
-1
Wikimedia.hs
src/Gargantext/Core/Text/Corpus/Parsers/Wikimedia.hs
+6
-6
Management.sh
src/Gargantext/Core/Text/List/Management.sh
+1
-1
Hetero.purs
src/Gargantext/Core/Text/Metrics/Hetero.purs
+3
-3
En.hs
src/Gargantext/Core/Text/Terms/Mono/Stem/En.hs
+2
-2
En.hs
src/Gargantext/Core/Text/Terms/Mono/Token/En.hs
+2
-2
Utils.hs
src/Gargantext/Core/Utils.hs
+1
-1
Prefix.hs
src/Gargantext/Core/Utils/Prefix.hs
+1
-1
Tools.hs
src/Gargantext/Core/Viz/Graph/Tools.hs
+4
-4
Types.hs
src/Gargantext/Core/Viz/Graph/Types.hs
+1
-1
TemporalMatching.hs
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
+1
-1
Search.hs
src/Gargantext/Database/Action/Search.hs
+1
-1
Contexts.hs
src/Gargantext/Database/Admin/Trigger/Contexts.hs
+1
-1
Node.hs
src/Gargantext/Database/Admin/Types/Node.hs
+1
-1
GargDB.hs
src/Gargantext/Database/GargDB.hs
+2
-2
Prelude.hs
src/Gargantext/Database/Prelude.hs
+3
-3
Add.hs
src/Gargantext/Database/Query/Table/Node/Document/Add.hs
+1
-1
Insert.hs
src/Gargantext/Database/Query/Table/Node/Document/Insert.hs
+2
-2
UpdateOpaleye.hs
src/Gargantext/Database/Query/Table/Node/UpdateOpaleye.hs
+1
-1
NodeContext.hs
src/Gargantext/Database/Query/Table/NodeContext.hs
+2
-2
Tree.hs
src/Gargantext/Database/Query/Tree.hs
+1
-1
Ngrams.hs
src/Gargantext/Database/Schema/Ngrams.hs
+1
-1
Jobs.hs
src/Gargantext/Utils/Jobs.hs
+3
-3
Internal.hs
src/Gargantext/Utils/Jobs/Internal.hs
+11
-11
Map.hs
src/Gargantext/Utils/Jobs/Map.hs
+7
-7
Monad.hs
src/Gargantext/Utils/Jobs/Monad.hs
+7
-7
Queue.hs
src/Gargantext/Utils/Jobs/Queue.hs
+9
-9
State.hs
src/Gargantext/Utils/Jobs/State.hs
+7
-7
Servant.hs
src/Gargantext/Utils/Servant.hs
+1
-1
No files found.
src/Gargantext/API.hs
View file @
5d5300cd
...
...
@@ -84,9 +84,9 @@ startGargantext mode port file = withLoggerHoisted mode $ \logger -> do
where
runDbCheck
env
=
do
r
<-
runExceptT
(
runReaderT
DB
.
dbCheck
env
)
`
catch
`
(
\
(
_
::
SomeException
)
->
return
$
Right
False
)
(
\
(
_
::
SomeException
)
->
pure
$
Right
False
)
case
r
of
Right
True
->
return
()
Right
True
->
pure
()
_
->
panic
$
"You must run 'gargantext-init "
<>
pack
file
<>
"' before running gargantext-server (only the first time)."
...
...
@@ -246,7 +246,7 @@ makeApp env = do
serv
<-
server
env
(
ekgStore
,
ekgMid
)
<-
newEkgStore
api
ekgDir
<-
(
</>
"ekg-assets"
)
<$>
getDataDir
return
$
ekgMid
$
serveWithContext
apiWithEkg
cfg
pure
$
ekgMid
$
serveWithContext
apiWithEkg
cfg
(
ekgServer
ekgDir
ekgStore
:<|>
serv
)
where
cfg
::
Servant
.
Context
AuthContext
...
...
src/Gargantext/API/EKG.hs
View file @
5d5300cd
...
...
@@ -40,7 +40,7 @@ newEkgStore api = do
registerGcMetrics
s
registerCounter
"ekg.server_timestamp_ms"
getTimeMs
s
-- used by UI
mid
<-
monitorEndpoints
api
s
return
(
s
,
mid
)
pure
(
s
,
mid
)
where
getTimeMs
=
(
round
.
(
*
1000
))
`
fmap
`
getPOSIXTime
...
...
src/Gargantext/API/Ngrams/List.hs
View file @
5d5300cd
...
...
@@ -97,7 +97,7 @@ getJson :: HasNodeStory env err m =>
getJson
lId
=
do
lst
<-
getNgramsList
lId
let
(
NodeId
id'
)
=
lId
return
$
addHeader
(
concat
[
"attachment; filename=GarganText_NgramsList-"
pure
$
addHeader
(
concat
[
"attachment; filename=GarganText_NgramsList-"
,
pack
$
show
id'
,
".json"
]
...
...
@@ -108,7 +108,7 @@ getCsv :: HasNodeStory env err m =>
getCsv
lId
=
do
lst
<-
getNgramsList
lId
let
(
NodeId
id'
)
=
lId
return
$
case
Map
.
lookup
TableNgrams
.
NgramsTerms
lst
of
pure
$
case
Map
.
lookup
TableNgrams
.
NgramsTerms
lst
of
Nothing
->
noHeader
Map
.
empty
Just
(
Versioned
{
_v_data
})
->
addHeader
(
concat
[
"attachment; filename=GarganText_NgramsList-"
...
...
src/Gargantext/API/Ngrams/Types.hs
View file @
5d5300cd
...
...
@@ -443,7 +443,7 @@ instance ToSchema a => ToSchema (Replace a) where
declareNamedSchema
(
_
::
Proxy
(
Replace
a
))
=
do
-- TODO Keep constructor is not supported here.
aSchema
<-
declareSchemaRef
(
Proxy
::
Proxy
a
)
return
$
NamedSchema
(
Just
"Replace"
)
$
mempty
pure
$
NamedSchema
(
Just
"Replace"
)
$
mempty
&
type_
?~
SwaggerObject
&
properties
.~
InsOrdHashMap
.
fromList
...
...
@@ -473,7 +473,7 @@ instance ToSchema NgramsPatch where
childrenSch
<-
declareSchemaRef
(
Proxy
::
Proxy
(
PatchMSet
NgramsTerm
))
listSch
<-
declareSchemaRef
(
Proxy
::
Proxy
(
Replace
ListType
))
nreSch
<-
declareSchemaRef
(
Proxy
::
Proxy
NgramsRepoElement
)
return
$
NamedSchema
(
Just
"NgramsPatch"
)
$
mempty
pure
$
NamedSchema
(
Just
"NgramsPatch"
)
$
mempty
&
type_
?~
SwaggerObject
&
properties
.~
InsOrdHashMap
.
fromList
...
...
src/Gargantext/API/Node/Corpus/Types.hs
View file @
5d5300cd
...
...
@@ -69,5 +69,5 @@ instance Arbitrary Datafield where
instance
ToSchema
Datafield
where
declareNamedSchema
_
=
do
return
$
NamedSchema
(
Just
"Datafield"
)
$
mempty
pure
$
NamedSchema
(
Just
"Datafield"
)
$
mempty
&
type_
?~
SwaggerObject
src/Gargantext/API/Node/Share.hs
View file @
5d5300cd
...
...
@@ -56,7 +56,7 @@ instance Arbitrary ShareNodeParams where
------------------------------------------------------------------------
-- TODO permission
-- TODO refactor userId which is used twice
-- TODO change
return
type for better warning/info/success/error handling on the front
-- TODO change
pure
type for better warning/info/success/error handling on the front
api
::
(
HasNodeError
err
,
HasNLPServer
env
,
CmdRandom
env
err
m
)
=>
User
->
NodeId
...
...
src/Gargantext/Core/Methods/Graph/MaxClique.hs
View file @
5d5300cd
...
...
@@ -16,7 +16,7 @@ def fast_maximal_cliques(g):
def rec_maximal_cliques(g, subv):
mc = []
if subv == []: # stop condition
return
[[]]
pure
[[]]
else :
for i in range(len(subv)):
newsubv = [j for j in subv[i+1:len(subv)]
...
...
@@ -25,7 +25,7 @@ def fast_maximal_cliques(g):
for x in mci:
x.append(subv[i])
mc.append(x)
return
mc
pure
mc
def purge(clust):
clustset = [set(x) for x in clust]
...
...
@@ -37,13 +37,13 @@ def fast_maximal_cliques(g):
ok = False
if ok and (not (clustset[i] in new_clust)):
new_clust.append(clustset[i])
return
[list(x) for x in new_clust]
pure
[list(x) for x in new_clust]
# to optimize : rank the vertices on the degrees
subv = [(v.index, v.degree()) for v in g.vs()]
subv.sort(key = lambda z:z[1])
subv = [x for (x, y) in subv]
return
purge(rec_maximal_cliques(g, subv))
pure
purge(rec_maximal_cliques(g, subv))
-}
...
...
src/Gargantext/Core/NodeStory.hs
View file @
5d5300cd
...
...
@@ -662,7 +662,7 @@ readNodeStoryEnv pool = do
-- printDebug "[readNodeStoryEnv] saver" mv
-- let mv' = clearHistory mv
-- printDebug "[readNodeStoryEnv] saver, cleared" mv'
--
return
mv'
--
pure
mv'
pure
$
NodeStoryEnv
{
_nse_var
=
mvar
,
_nse_saver
=
saver
,
_nse_saver_immediate
=
saver_immediate
...
...
src/Gargantext/Core/Text/Corpus/Parsers/Date/Parsec.hs
View file @
5d5300cd
...
...
@@ -30,7 +30,7 @@ import qualified Text.ParserCombinators.Parsec (parse)
-- | Permit to transform a String to an Int in a monadic context
wrapDST
::
Monad
m
=>
String
->
m
Int
wrapDST
=
return
.
decimalStringToInt
wrapDST
=
pure
.
decimalStringToInt
-- | Generic parser which take at least one element not given in argument
many1NoneOf
::
Stream
s
m
Char
=>
[
Char
]
->
ParsecT
s
u
m
[
Char
]
...
...
@@ -50,7 +50,7 @@ parseGregorian = do
_
<-
char
'-'
d
<-
wrapDST
=<<
many1NoneOf
[
'T'
]
_
<-
char
'T'
return
$
fromGregorian
(
toInteger
y
)
m
d
pure
$
fromGregorian
(
toInteger
y
)
m
d
---- | Parser for time format h:m:s
parseTimeOfDay
::
Parser
TimeOfDay
...
...
@@ -64,7 +64,7 @@ parseTimeOfDay = do
dec
<-
many1NoneOf
[
'+'
,
'-'
]
let
(
nb
,
l
)
=
(
decimalStringToInt
$
r
++
dec
,
length
dec
)
seconds
=
nb
*
10
^
(
12
-
l
)
return
$
TimeOfDay
h
m
(
MkFixed
.
toInteger
$
seconds
)
pure
$
TimeOfDay
h
m
(
MkFixed
.
toInteger
$
seconds
)
-- | Parser for timezone format +hh:mm
...
...
@@ -75,7 +75,7 @@ parseTimeZone = do
_
<-
char
':'
m
<-
wrapDST
=<<
(
many1
$
anyChar
)
let
timeInMinute
=
if
sign
==
'+'
then
h
*
60
+
m
else
-
h
*
60
-
m
in
return
$
TimeZone
timeInMinute
False
"CET"
in
pure
$
TimeZone
timeInMinute
False
"CET"
---- | Parser which use parseGregorian, parseTimeOfDay and parseTimeZone to create a ZonedTime
parseZonedTime
::
Parser
ZonedTime
...
...
@@ -83,7 +83,7 @@ parseZonedTime= do
d
<-
parseGregorian
tod
<-
parseTimeOfDay
tz
<-
parseTimeZone
return
$
ZonedTime
(
LocalTime
d
(
tod
))
tz
pure
$
ZonedTime
(
LocalTime
d
(
tod
))
tz
---- | Opposite of toRFC3339
fromRFC3339
::
Text
->
Either
ParseError
ZonedTime
...
...
src/Gargantext/Core/Text/Corpus/Parsers/Iramuteq.hs
View file @
5d5300cd
...
...
@@ -63,7 +63,7 @@ fieldTuple = do
constP
::
Parser
a
->
ByteString
->
Parser
a
constP
p
t
=
case
parseOnly
p
t
of
Left
_
->
empty
Right
a
->
return
a
Right
a
->
pure
a
parseOf
::
Parser
ByteString
->
Parser
a
->
Parser
a
parseOf
ptxt
pa
=
bothParse
<|>
empty
...
...
src/Gargantext/Core/Text/Corpus/Parsers/Wikimedia.hs
View file @
5d5300cd
...
...
@@ -52,7 +52,7 @@ parseRevision :: MonadThrow m => ConduitT Event o m (Maybe T.Text)
parseRevision
=
tagNoAttr
"{http://www.mediawiki.org/xml/export-0.10/}revision"
$
do
text
<-
force
"text is missing"
$
ignoreExcept
"{http://www.mediawiki.org/xml/export-0.10/}text"
content
many_
ignoreAnyTreeContent
return
text
pure
text
-- | Utility function that matches everything but the tag given
tagUntil
::
Name
->
NameMatcher
Name
...
...
@@ -95,7 +95,7 @@ parsePage =
revision
<-
parseRevision
many_
$
ignoreAnyTreeContent
return
$
Page
{
_markupFormat
=
Mediawiki
pure
$
Page
{
_markupFormat
=
Mediawiki
,
_title
=
title
,
_text
=
revision
}
...
...
@@ -110,14 +110,14 @@ mediawikiPageToPlain :: Page -> IO Page
mediawikiPageToPlain
page
=
do
title
<-
mediaToPlain
$
_title
page
revision
<-
mediaToPlain
$
_text
page
return
$
Page
{
_markupFormat
=
Plaintext
,
_title
=
title
,
_text
=
revision
}
pure
$
Page
{
_markupFormat
=
Plaintext
,
_title
=
title
,
_text
=
revision
}
where
mediaToPlain
media
=
case
media
of
(
Nothing
)
->
return
Nothing
(
Nothing
)
->
pure
Nothing
(
Just
med
)
->
do
res
<-
runIO
$
do
doc
<-
readMediaWiki
def
med
writePlain
def
doc
case
res
of
(
Left
_
)
->
return
Nothing
(
Right
r
)
->
return
$
Just
r
(
Left
_
)
->
pure
Nothing
(
Right
r
)
->
pure
$
Just
r
src/Gargantext/Core/Text/List/Management.sh
View file @
5d5300cd
...
...
@@ -74,7 +74,7 @@ restrictListSize corpusId listId ngramsType listType size = do
ngrams'
<- filterWith listType size occurrences ngrams
_ <- setListNgrams listId ngramsType ngrams
'
return
()
pure
()
where filterWith :: ListType -> Int -> HashMap NgramsTerm Int
-> HashMap NgramsTerm NgramsRepoElement
...
...
src/Gargantext/Core/Text/Metrics/Hetero.purs
View file @
5d5300cd
...
...
@@ -46,7 +46,7 @@ dicoStruct :: (Integral r, Monad m) => M.Map t r -> m r
dicoStruct dict_occ = do
let keys_size = toInteger $ length $ M.keys dict_occ
let total_occ = sum $ Prelude.map (\(x, y) -> y) $ M.toList dict_occ
return
$ div total_occ (fromIntegral keys_size)
pure
$ div total_occ (fromIntegral keys_size)
-- heterogeinity sur UCT (Unité de Context Textuel)
heterogeinity :: [Char] -> IO Integer
...
...
@@ -56,7 +56,7 @@ heterogeinity string = do
let keys_size = toInteger $ length $ M.keys dict_occ
let total_occ = sum $ Prelude.map (\(x, y) -> y) $ M.toList dict_occ
return
$ div total_occ (fromIntegral keys_size)
pure
$ div total_occ (fromIntegral keys_size)
--computeHeterogeinity
...
...
@@ -79,6 +79,6 @@ main2 = do
]
r <- Prelude.map computeHeterogeinity $ Prelude.map (\(t,id) -> id) corpus_ids
return
r
pure
r
src/Gargantext/Core/Text/Terms/Mono/Stem/En.hs
View file @
5d5300cd
...
...
@@ -83,7 +83,7 @@ statefulReplace predicate str end replacement
replaceEnd
::
Eq
a
=>
([
a
]
->
Bool
)
->
[
a
]
->
[
a
]
->
[
a
]
->
Maybe
[
a
]
replaceEnd
predicate
str
end
replacement
=
do
result
<-
statefulReplace
predicate
str
end
replacement
return
(
either
identity
identity
result
)
pure
(
either
identity
identity
result
)
findStem
::
(
Foldable
t
,
Functor
t
,
Eq
a
)
=>
...
...
@@ -103,7 +103,7 @@ beforeStep1b :: [Char] -> Either [Char] [Char]
beforeStep1b
word
=
fromMaybe
(
Left
word
)
result
where
cond23
x
=
do
{
v
<-
x
;
either
(
const
Nothing
)
(
return
.
Right
)
v
}
cond1
x
=
do
{
v
<-
x
;
return
(
Left
v
)
}
cond1
x
=
do
{
v
<-
x
;
pure
(
Left
v
)
}
result
=
cond1
(
replaceEnd
(
measureGT
0
)
word
"eed"
"ee"
)
`
mplus
`
cond23
(
statefulReplace
containsVowel
word
"ed"
""
)
`
mplus
`
...
...
src/Gargantext/Core/Text/Terms/Mono/Token/En.hs
View file @
5d5300cd
...
...
@@ -131,7 +131,7 @@ negatives x | "n't" `T.isSuffixOf` x = E [ Right . T.reverse . T.drop 3 . T.reve
-- | Currently deals with: 'm, 's, 'd, 've, 'll
contractions
::
Tokenizer
contractions
x
=
case
catMaybes
.
map
(
splitSuffix
x
)
$
cts
of
[]
->
return
x
[]
->
pure
x
((
w
,
s
)
:
_
)
->
E
[
Right
w
,
Left
s
]
where
cts
=
[
"'m"
,
"'s"
,
"'d"
,
"'ve"
,
"'ll"
]
splitSuffix
w
sfx
=
...
...
@@ -151,7 +151,7 @@ instance Monad (EitherList a) where
E
xs
>>=
f
=
E
$
concatMap
(
either
(
return
.
Left
)
(
unE
.
f
))
xs
instance
Applicative
(
EitherList
a
)
where
pure
x
=
return
x
pure
=
pure
f
<*>
x
=
f
`
ap
`
x
instance
Functor
(
EitherList
a
)
where
...
...
src/Gargantext/Core/Utils.hs
View file @
5d5300cd
...
...
@@ -62,7 +62,7 @@ randomString num = do
pure
$
pack
str
-- | Given a list of items of type 'a',
return
list with unique items
-- | Given a list of items of type 'a',
pure
list with unique items
-- (like List.nub) but tuple-d with their counts in the original list
groupWithCounts
::
(
Ord
a
,
Eq
a
)
=>
[
a
]
->
[(
a
,
Int
)]
groupWithCounts
=
map
f
...
...
src/Gargantext/Core/Utils/Prefix.hs
View file @
5d5300cd
...
...
@@ -65,4 +65,4 @@ parseJSONFromString v = do
numString
<-
parseJSON
v
case
readMaybe
(
numString
::
String
)
of
Nothing
->
fail
$
"Invalid number for TransactionID: "
++
show
v
-- TODO error message too specific
Just
n
->
return
n
Just
n
->
pure
n
src/Gargantext/Core/Viz/Graph/Tools.hs
View file @
5d5300cd
...
...
@@ -117,7 +117,7 @@ cooc2graphWith' :: Partitions
->
IO
Graph
cooc2graphWith'
_doPartitions
_bridgenessMethod
multi
similarity
threshold
strength
myCooc
=
do
let
(
distanceMap
,
diag
,
ti
)
=
doSimilarityMap
similarity
threshold
strength
myCooc
distanceMap
`
seq
`
diag
`
seq
`
ti
`
seq
`
return
()
distanceMap
`
seq
`
diag
`
seq
`
ti
`
seq
`
pure
()
partitions
<-
if
(
Map
.
size
distanceMap
>
0
)
then
recursiveClustering'
(
spinglass'
1
)
distanceMap
...
...
@@ -129,7 +129,7 @@ cooc2graphWith' _doPartitions _bridgenessMethod multi similarity threshold stren
,
"Follow the available tutorials on the Training EcoSystems."
,
"Ask your co-users of GarganText how to have access to it."
]
length
partitions
`
seq
`
return
()
length
partitions
`
seq
`
pure
()
let
!
confluence'
=
BAC
.
computeConfluences
3
(
Map
.
keys
distanceMap
)
True
...
...
@@ -140,7 +140,7 @@ cooc2graphWith' _doPartitions _bridgenessMethod multi similarity threshold stren
{-
cooc2graphWith' _doPartitions _bridgenessMethod multi similarity@Distributional threshold strength myCooc = do
let (distanceMap, diag, ti) = doSimilarityMap similarity threshold strength myCooc
distanceMap `seq` diag `seq` ti `seq`
return
()
distanceMap `seq` diag `seq` ti `seq`
pure
()
partitions <- if (Map.size distanceMap > 0)
then recursiveClustering (spinglass 1) distanceMap
...
...
@@ -148,7 +148,7 @@ cooc2graphWith' _doPartitions _bridgenessMethod multi similarity@Distributional
, "Maybe you should add more Map Terms in your list"
, "Tutorial: TODO"
]
length partitions `seq`
return
()
length partitions `seq`
pure
()
let
!confluence' = BAC.computeConfluences 3 (Map.keys distanceMap) True
...
...
src/Gargantext/Core/Viz/Graph/Types.hs
View file @
5d5300cd
...
...
@@ -229,7 +229,7 @@ instance DefaultFromField SqlJsonb HyperdataGraph
defaultFromField
=
fromPGSFromField
-----------------------------------------------------------
-- This type is used to
return
graph via API
-- This type is used to
pure
graph via API
-- hyperdataGraphAPI field is not a Maybe anymore – graph is always computed
data
HyperdataGraphAPI
=
HyperdataGraphAPI
{
_hyperdataAPIGraph
::
Graph
...
...
src/Gargantext/Core/Viz/Phylo/TemporalMatching.hs
View file @
5d5300cd
...
...
@@ -616,7 +616,7 @@ separateBranches fdt similarity lambda frequency minBranch thr rise timescale do
((
map
(
\
e
->
(
e
,
True
))
(
fst
branches'
))
++
(
map
(
\
e
->
(
e
,
False
))
(
snd
branches'
))))
else
[
currentBranch
])
in
-- 6) if there is no more branch to separate tne
return
[done'] else continue with [rest]
-- 6) if there is no more branch to separate tne
pure
[done'] else continue with [rest]
if
null
rest
then
done'
else
separateBranches
fdt
similarity
lambda
frequency
minBranch
thr
rise
timescale
docs
coocs
roots
periods
...
...
src/Gargantext/Database/Action/Search.hs
View file @
5d5300cd
...
...
@@ -116,7 +116,7 @@ searchInCorpusWithNgrams _cId _lId _t _ngt _q _o _l _order = undefined
-- | Compute TF-IDF for all 'ngramIds' in given 'CorpusId'. In this
-- case only the "TF" part makes sense and so we only compute the
-- ratio of "number of times our terms appear in given document" and
-- "number of all terms in document" and
return
a sorted list of
-- "number of all terms in document" and
pure
a sorted list of
-- document ids
_tfidfAll
::
(
HasDBid
NodeType
,
HasNodeError
err
)
=>
CorpusId
->
[
Int
]
->
DBCmd
err
[
Int
]
_tfidfAll
cId
ngramIds
=
do
...
...
src/Gargantext/Database/Admin/Trigger/Contexts.hs
View file @
5d5300cd
...
...
@@ -51,7 +51,7 @@ triggerSearchUpdate = execPGSQuery query ( toDBid NodeDocument
ELSE
new.search := to_tsvector( 'english' , new.hyperdata::jsonb );
END IF;
return
new;
pure
new;
end
$$ LANGUAGE plpgsql;
...
...
src/Gargantext/Database/Admin/Types/Node.hs
View file @
5d5300cd
...
...
@@ -225,7 +225,7 @@ instance FromField NodeId where
fromField
field
mdata
=
do
n
<-
fromField
field
mdata
if
(
n
::
Int
)
>
0
then
return
$
NodeId
n
then
pure
$
NodeId
n
else
mzero
instance
ToSchema
NodeId
...
...
src/Gargantext/Database/GargDB.hs
View file @
5d5300cd
...
...
@@ -188,7 +188,7 @@ onDisk_1 action fp = do
liftBase
$
action
(
toFilePath
dataPath
fp
)
`
catch
`
handleExists
where
handleExists
e
|
isDoesNotExistError
e
=
return
()
|
isDoesNotExistError
e
=
pure
()
|
otherwise
=
throwIO
e
...
...
@@ -207,6 +207,6 @@ onDisk_2 action fp1 fp2 = do
liftBase
$
action
fp1'
fp2'
`
catch
`
handleExists
where
handleExists
e
|
isDoesNotExistError
e
=
return
()
|
isDoesNotExistError
e
=
pure
()
|
otherwise
=
throwIO
e
------------------------------------------------------------------------
src/Gargantext/Database/Prelude.hs
View file @
5d5300cd
...
...
@@ -141,7 +141,7 @@ runOpaQuery q = mkCmd $ \c -> runSelect c q
runCountOpaQuery
::
Select
a
->
DBCmd
err
Int
runCountOpaQuery
q
=
do
counts
<-
mkCmd
$
\
c
->
runSelect
c
$
countRows
q
-- countRows is guaranteed to
return
a list with exactly one row so DL.head is safe here
-- countRows is guaranteed to
pure
a list with exactly one row so DL.head is safe here
pure
$
fromInt64ToInt
$
DL
.
head
counts
formatPGSQuery
::
PGS
.
ToRow
a
=>
PGS
.
Query
->
a
->
Cmd
err
DB
.
ByteString
...
...
@@ -231,8 +231,8 @@ dbCheck :: CmdM env err m => m Bool
dbCheck
=
do
r
::
[
PGS
.
Only
Text
]
<-
runPGSQuery_
"select username from public.auth_user"
case
r
of
[]
->
return
False
_
->
return
True
[]
->
pure
False
_
->
pure
True
restrictMaybe
::
(
Default
Opaleye
.
Internal
.
Operators
.
IfPP
b
b
,
(
Default
Opaleye
.
Internal
.
Constant
.
ToFields
Bool
b
))
...
...
src/Gargantext/Database/Query/Table/Node/Document/Add.hs
View file @
5d5300cd
...
...
@@ -58,7 +58,7 @@ inputSqlTypes :: [Text]
inputSqlTypes
=
[
"int4"
,
"int4"
,
"int4"
,
"int4"
]
-- | SQL query to add documents
-- TODO
return
id of added documents only
-- TODO
pure
id of added documents only
queryAdd
::
Query
queryAdd
=
[
sql
|
WITH input_rows(node_id,context_id,score,category) AS (?)
...
...
src/Gargantext/Database/Query/Table/Node/Document/Insert.hs
View file @
5d5300cd
...
...
@@ -159,7 +159,7 @@ queryInsert = [sql|
, ins AS (
INSERT INTO contexts (hash_id, typename,user_id,parent_id,name,date,hyperdata)
SELECT * FROM input_rows
ON CONFLICT (hash_id) DO NOTHING -- on unique index -- this does not
return
the ids
ON CONFLICT (hash_id) DO NOTHING -- on unique index -- this does not
pure
the ids
RETURNING id,hash_id
)
...
...
@@ -182,7 +182,7 @@ queryInsert = [sql|
-- | When documents are inserted
-- ReturnType after insertion
data
ReturnId
=
ReturnId
{
reInserted
::
Bool
-- if the document is inserted (True: is new, False: is not new)
,
reId
::
NodeId
-- always
return
the id of the document (even new or not new)
,
reId
::
NodeId
-- always
pure
the id of the document (even new or not new)
-- this is the uniq id in the database
,
reUniqId
::
Text
-- Hash Id with concatenation of sha parameters
}
deriving
(
Show
,
Generic
)
...
...
src/Gargantext/Database/Query/Table/Node/UpdateOpaleye.hs
View file @
5d5300cd
...
...
@@ -31,7 +31,7 @@ import Gargantext.Database.Query.Table.Node.Error
updateHyperdata
::
HyperdataC
a
=>
NodeId
->
a
->
DBCmd
err
Int64
updateHyperdata
i
h
=
mkCmd
$
\
c
->
putStrLn
"before runUpdate_"
>>
runUpdate_
c
(
updateHyperdataQuery
i
h
)
>>=
\
res
->
putStrLn
"after runUpdate_"
>>
return
res
putStrLn
"after runUpdate_"
>>
pure
res
updateHyperdataQuery
::
HyperdataC
a
=>
NodeId
->
a
->
Update
Int64
updateHyperdataQuery
i
h
=
seq
h'
$
{- trace "updateHyperdataQuery: encoded JSON" $ -}
Update
...
...
src/Gargantext/Database/Query/Table/NodeContext.hs
View file @
5d5300cd
...
...
@@ -192,7 +192,7 @@ getContextsForNgramsTerms cId ngramsTerms = do
-- | Query the `context_node_ngrams` table and
return
ngrams for given
-- | Query the `context_node_ngrams` table and
pure
ngrams for given
-- `context_id` and `list_id`.
-- WARNING: `context_node_ngrams` can be outdated. This is because it
-- is expensive to keep all ngrams matching a given context and if
...
...
@@ -215,7 +215,7 @@ getContextNgrams contextId listId = do
AND node_id = ?
|]
-- | Query the `contexts` table and
return
ngrams for given context_id
-- | Query the `contexts` table and
pure
ngrams for given context_id
-- and list_id that match the search tsvector.
-- NOTE This is poor man's tokenization that is used as a hint for the
-- frontend highlighter.
...
...
src/Gargantext/Database/Query/Tree.hs
View file @
5d5300cd
...
...
@@ -7,7 +7,7 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Let a Root Node,
return
the Tree of the Node as a directed acyclic graph
Let a Root Node,
pure
the Tree of the Node as a directed acyclic graph
(Tree).
-- TODO delete node, if not owned, then suppress the link only
...
...
src/Gargantext/Database/Schema/Ngrams.hs
View file @
5d5300cd
...
...
@@ -145,7 +145,7 @@ instance ToField NgramsTypeId where
instance
FromField
NgramsTypeId
where
fromField
fld
mdata
=
do
n
<-
fromField
fld
mdata
if
(
n
::
Int
)
>
0
then
return
$
NgramsTypeId
n
if
(
n
::
Int
)
>
0
then
pure
$
NgramsTypeId
n
else
mzero
instance
DefaultFromField
(
Nullable
SqlInt4
)
NgramsTypeId
where
...
...
src/Gargantext/Utils/Jobs.hs
View file @
5d5300cd
...
...
@@ -65,13 +65,13 @@ parseGargJob s = case s of
_
->
Nothing
parsePrios
::
[
String
]
->
IO
[(
GargJob
,
Int
)]
parsePrios
[]
=
return
[]
parsePrios
[]
=
pure
[]
parsePrios
(
x
:
xs
)
=
(
:
)
<$>
go
x
<*>
parsePrios
xs
where
go
s
=
case
break
(
==
'='
)
s
of
(
[]
,
_
)
->
error
"parsePrios: empty jobname?"
(
prop
,
valS
)
|
Just
val
<-
readMaybe
(
tail
valS
)
,
Just
j
<-
parseGargJob
prop
->
return
(
j
,
val
)
,
Just
j
<-
parseGargJob
prop
->
pure
(
j
,
val
)
|
otherwise
->
error
$
"parsePrios: invalid input. "
++
show
(
prop
,
valS
)
...
...
@@ -82,5 +82,5 @@ readPrios fp = do
False
->
do
putStrLn
$
"Warning: "
++
fp
++
" doesn't exist, using default job priorities."
return
[]
pure
[]
True
->
parsePrios
.
lines
=<<
readFile
fp
src/Gargantext/Utils/Jobs/Internal.hs
View file @
5d5300cd
...
...
@@ -96,10 +96,10 @@ newJob newJobHandle getenv jobkind f input = do
r
<-
f
env
(
newJobHandle
jId
(
liftIO
.
pushLog
logF
.
Seq
.
singleton
))
inp
case
r
of
Left
e
->
postCallback
(
SJ
.
mkChanError
e
)
>>
throwIO
e
Right
a
->
postCallback
(
SJ
.
mkChanResult
a
)
>>
return
a
Right
a
->
postCallback
(
SJ
.
mkChanResult
a
)
>>
pure
a
jid
<-
queueJob
jobkind
(
input
^.
SJ
.
job_input
)
f'
return
(
SJ
.
JobStatus
jid
[]
SJ
.
IsPending
Nothing
)
pure
(
SJ
.
JobStatus
jid
[]
SJ
.
IsPending
Nothing
)
pollJob
::
MonadJob
m
t
(
Seq
event
)
output
...
...
@@ -119,7 +119,7 @@ pollJob limit offset jid je = do
me
=
either
(
Just
.
T
.
pack
.
show
)
(
const
Nothing
)
r
in
pure
(
ls
,
st
,
me
)
-- /NOTE/: We need to be careful with the ordering of the logs here:
-- we want to
return
the logs ordered from the newest to the oldest,
-- we want to
pure
the logs ordered from the newest to the oldest,
-- because the API will use 'limit' to show only the newest ones,
-- taking 'limit' of them from the front of the list.
--
...
...
@@ -141,15 +141,15 @@ waitJob joberr jid je = do
m
<-
getJobsMap
erj
<-
waitTilRunning
case
erj
of
Left
res
->
return
res
Left
res
->
pure
res
Right
rj
->
do
(
res
,
_logs
)
<-
liftIO
(
waitJobDone
jid
rj
m
)
return
res
pure
res
RunningJ
rj
->
do
m
<-
getJobsMap
(
res
,
_logs
)
<-
liftIO
(
waitJobDone
jid
rj
m
)
return
res
DoneJ
_ls
res
->
return
res
pure
res
DoneJ
_ls
res
->
pure
res
either
(
throwError
.
joberr
.
JobException
)
(
pure
.
SJ
.
JobOutput
)
r
where
waitTilRunning
=
...
...
@@ -159,8 +159,8 @@ waitJob joberr jid je = do
QueuedJ
_qj
->
do
liftIO
$
threadDelay
50000
-- wait 50ms
waitTilRunning
RunningJ
rj
->
return
(
Right
rj
)
DoneJ
_ls
res
->
return
(
Left
res
)
RunningJ
rj
->
pure
(
Right
rj
)
DoneJ
_ls
res
->
pure
(
Left
res
)
killJob
::
(
Ord
t
,
MonadJob
m
t
(
Seq
event
)
output
)
...
...
@@ -174,12 +174,12 @@ killJob t limit offset jid je = do
(
logs
,
status
,
merr
)
<-
case
jTask
je
of
QueuedJ
_
->
do
removeJob
True
t
jid
return
(
mempty
,
SJ
.
IsKilled
,
Nothing
)
pure
(
mempty
,
SJ
.
IsKilled
,
Nothing
)
RunningJ
rj
->
do
liftIO
$
cancel
(
rjAsync
rj
)
lgs
<-
liftIO
(
rjGetLog
rj
)
removeJob
False
t
jid
return
(
lgs
,
SJ
.
IsKilled
,
Nothing
)
pure
(
lgs
,
SJ
.
IsKilled
,
Nothing
)
DoneJ
lgs
r
->
do
let
st
=
either
(
const
SJ
.
IsFailure
)
(
const
SJ
.
IsFinished
)
r
me
=
either
(
Just
.
T
.
pack
.
show
)
(
const
Nothing
)
r
...
...
src/Gargantext/Utils/Jobs/Map.hs
View file @
5d5300cd
...
...
@@ -104,10 +104,10 @@ gcThread js (JobMap mvar) = go
mrunningjob
<-
atomically
$
do
case
jTask
je
of
RunningJ
rj
->
modifyTVar'
mvar
(
Map
.
delete
(
jID
je
))
>>
return
(
Just
rj
)
_
->
return
Nothing
>>
pure
(
Just
rj
)
_
->
pure
Nothing
case
mrunningjob
of
Nothing
->
return
()
Nothing
->
pure
()
Just
a
->
killJ
a
go
...
...
@@ -161,7 +161,7 @@ runJob jid qj (JobMap mvar) js = do
,
jStarted
=
Just
now
,
jTimeoutAfter
=
Just
$
addUTCTime
(
fromIntegral
(
jsJobTimeout
js
))
now
}
return
rj
pure
rj
waitJobDone
::
Ord
jid
...
...
@@ -176,7 +176,7 @@ waitJobDone jid rj (JobMap mvar) = do
atomically
$
modifyTVar'
mvar
$
flip
Map
.
adjust
jid
$
\
je
->
je
{
jEnded
=
Just
now
,
jTask
=
DoneJ
logs
r
}
return
(
r
,
logs
)
pure
(
r
,
logs
)
-- | Turn a queued job into a running job by setting up the logging of @w@s and
-- firing up the async action.
...
...
@@ -185,9 +185,9 @@ runJ (QueuedJob a f) = do
logs
<-
newTVarIO
mempty
act
<-
async
$
f
a
(
jobLog
logs
)
let
readLogs
=
readTVarIO
logs
return
(
RunningJob
act
readLogs
)
pure
(
RunningJob
act
readLogs
)
-- | Wait for a running job to
return
(blocking).
-- | Wait for a running job to
pure
(blocking).
waitJ
::
RunningJob
w
a
->
IO
(
Either
SomeException
a
)
waitJ
(
RunningJob
act
_
)
=
waitCatch
act
...
...
src/Gargantext/Utils/Jobs/Monad.hs
View file @
5d5300cd
...
...
@@ -126,10 +126,10 @@ checkJID
checkJID
(
SJ
.
PrivateID
tn
n
t
d
)
=
do
now
<-
liftIO
getCurrentTime
js
<-
getJobsSettings
if
|
tn
/=
"job"
->
return
(
Left
InvalidIDType
)
|
now
>
addUTCTime
(
fromIntegral
$
jsIDTimeout
js
)
t
->
return
(
Left
IDExpired
)
|
d
/=
SJ
.
macID
tn
(
jsSecretKey
js
)
t
n
->
return
(
Left
$
InvalidMacID
$
T
.
pack
d
)
|
otherwise
->
return
$
Right
(
SJ
.
PrivateID
tn
n
t
d
)
if
|
tn
/=
"job"
->
pure
(
Left
InvalidIDType
)
|
now
>
addUTCTime
(
fromIntegral
$
jsIDTimeout
js
)
t
->
pure
(
Left
IDExpired
)
|
d
/=
SJ
.
macID
tn
(
jsSecretKey
js
)
t
n
->
pure
(
Left
$
InvalidMacID
$
T
.
pack
d
)
|
otherwise
->
pure
$
Right
(
SJ
.
PrivateID
tn
n
t
d
)
withJob
::
MonadJob
m
t
w
a
...
...
@@ -139,11 +139,11 @@ withJob
withJob
jid
f
=
do
r
<-
checkJID
jid
case
r
of
Left
e
->
return
(
Left
e
)
Left
e
->
pure
(
Left
e
)
Right
jid'
->
do
mj
<-
findJob
jid'
case
mj
of
Nothing
->
return
(
Right
Nothing
)
Nothing
->
pure
(
Right
Nothing
)
Just
j
->
Right
.
Just
<$>
f
jid'
j
handleIDError
...
...
@@ -153,7 +153,7 @@ handleIDError
->
m
a
handleIDError
toE
act
=
act
>>=
\
r
->
case
r
of
Left
err
->
throwError
(
toE
err
)
Right
a
->
return
a
Right
a
->
pure
a
removeJob
::
(
Ord
t
,
MonadJob
m
t
w
a
)
...
...
src/Gargantext/Utils/Jobs/Queue.hs
View file @
5d5300cd
...
...
@@ -91,7 +91,7 @@ newQueue prios = do
indices
=
Map
.
fromList
(
zip
allTs
[
0
..
])
n
=
Map
.
size
indices
vars
<-
Vector
.
replicateM
n
(
newTVarIO
emptyQ
)
return
$
Queue
vars
indices
prios
pure
$
Queue
vars
indices
prios
-- | Add a new element to the queue, with the given kind.
addQueue
::
Ord
t
=>
t
->
a
->
Queue
t
a
->
STM
()
...
...
@@ -110,7 +110,7 @@ debugDumpQueue q = mconcat <$> (forM [minBound..maxBound] $ \t -> do
readTVar
(
queueData
q
Vector
.!
(
i
t
))
>>=
debugDumpQ
t
)
where
i
t
=
fromJust
$
Map
.
lookup
t
(
queueIndices
q
)
debugDumpQ
t
(
Q
xs
ys
_
)
=
return
$
map
(
\
x
->
(
t
,
x
))
(
xs
++
reverse
ys
)
debugDumpQ
t
(
Q
xs
ys
_
)
=
pure
$
map
(
\
x
->
(
t
,
x
))
(
xs
++
reverse
ys
)
type
Picker
a
=
[(
a
,
STM
()
)]
->
STM
(
a
,
STM
()
)
...
...
@@ -127,7 +127,7 @@ popQueue picker q = atomically $ select prioLevels
Map
.
toList
(
queuePrios
q
)
select
::
[[(
t
,
Prio
)]]
->
STM
(
Maybe
a
)
select
[]
=
return
Nothing
select
[]
=
pure
Nothing
select
(
level
:
levels
)
=
do
mres
<-
selectLevel
level
case
mres
of
...
...
@@ -139,15 +139,15 @@ popQueue picker q = atomically $ select prioLevels
let
indices
=
catMaybes
$
map
(
flip
Map
.
lookup
(
queueIndices
q
)
.
fst
)
xs
queues
=
map
(
queueData
q
Vector
.!
)
indices
go
qvar
=
readTVar
qvar
>>=
\
qu
->
return
(
peekQ
qu
,
modifyTVar'
qvar
dropQ
)
pure
(
peekQ
qu
,
modifyTVar'
qvar
dropQ
)
mtopItems
<-
catMaybesFst
<$>
traverse
go
queues
case
mtopItems
of
Nothing
->
return
Nothing
Just
[]
->
return
Nothing
Nothing
->
pure
Nothing
Just
[]
->
pure
Nothing
Just
topItems
->
do
(
earliestItem
,
popItem
)
<-
picker
topItems
popItem
return
(
Just
earliestItem
)
pure
(
Just
earliestItem
)
catMaybesFst
((
Nothing
,
_b
)
:
xs
)
=
catMaybesFst
xs
catMaybesFst
((
Just
a
,
b
)
:
xs
)
=
((
a
,
b
)
:
)
<$>
catMaybesFst
xs
...
...
@@ -162,7 +162,7 @@ queueRunner picker f q = go
mres
<-
popQueue
picker
q
case
mres
of
Just
a
->
f
a
`
catch
`
exc
Nothing
->
return
()
Nothing
->
pure
()
threadDelay
5000
-- 5ms
go
...
...
@@ -181,4 +181,4 @@ newQueueWithRunners
newQueueWithRunners
n
prios
picker
f
=
do
q
<-
newQueue
prios
let
runners
=
replicate
n
(
queueRunner
picker
f
q
)
return
(
q
,
runners
)
pure
(
q
,
runners
)
src/Gargantext/Utils/Jobs/State.hs
View file @
5d5300cd
...
...
@@ -46,17 +46,17 @@ newJobsState js prios = do
(
q
,
runners
)
<-
newQueueWithRunners
(
jsNumRunners
js
)
prios
(
picker
jmap
)
$
\
jid
->
do
mje
<-
lookupJob
jid
jmap
case
mje
of
Nothing
->
return
()
Nothing
->
pure
()
Just
je
->
case
jTask
je
of
QueuedJ
qj
->
do
rj
<-
runJob
jid
qj
jmap
js
(
_res
,
_logs
)
<-
waitJobDone
jid
rj
jmap
return
()
_
->
return
()
pure
()
_
->
pure
()
when
(
jsDebugLogs
js
)
$
putStrLn
$
"Starting "
++
show
(
jsNumRunners
js
)
++
" job runners."
gcAsync
<-
async
$
gcThread
js
jmap
runnersAsyncs
<-
traverse
async
runners
return
(
JobsState
jmap
q
idgen
gcAsync
runnersAsyncs
)
pure
(
JobsState
jmap
q
idgen
gcAsync
runnersAsyncs
)
where
picker
::
JobMap
(
SJ
.
JobID
'S
J
.
Safe
)
w
a
...
...
@@ -65,10 +65,10 @@ newJobsState js prios = do
jinfos
<-
fmap
catMaybes
.
forM
xs
$
\
(
jid
,
popjid
)
->
do
mje
<-
Map
.
lookup
jid
<$>
readTVar
jmap
case
mje
of
Nothing
->
return
Nothing
Just
je
->
return
$
Just
(
jid
,
popjid
,
jRegistered
je
)
Nothing
->
pure
Nothing
Just
je
->
pure
$
Just
(
jid
,
popjid
,
jRegistered
je
)
let
(
jid
,
popjid
,
_
)
=
List
.
minimumBy
(
comparing
_3
)
jinfos
return
(
jid
,
popjid
)
pure
(
jid
,
popjid
)
_3
(
_
,
_
,
c
)
=
c
...
...
src/Gargantext/Utils/Servant.hs
View file @
5d5300cd
...
...
@@ -45,7 +45,7 @@ instance MimeRender CSV NgramsTableMap where
instance
Read
a
=>
MimeUnrender
CSV
a
where
mimeUnrender
_
bs
=
case
BSC
.
take
len
bs
of
"text/csv"
->
return
.
read
.
BSC
.
unpack
$
BSC
.
drop
len
bs
"text/csv"
->
pure
.
read
.
BSC
.
unpack
$
BSC
.
drop
len
bs
_
->
Left
"didn't start with the magic incantation"
where
len
::
Int64
...
...
Przemyslaw Kaminski
@cgenie
mentioned in commit
ffc99385
·
Sep 28, 2023
mentioned in commit
ffc99385
mentioned in commit ffc99385b6b715297d40b48a490bb131aa0c934b
Toggle commit list
Przemyslaw Kaminski
@cgenie
mentioned in merge request
!206 (merged)
·
Sep 28, 2023
mentioned in merge request
!206 (merged)
mentioned in merge request !206
Toggle commit list
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment