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
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
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
Christian Merten
haskell-gargantext
Commits
5d5300cd
Commit
5d5300cd
authored
Sep 21, 2023
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[CLEAN] return -> pure to make hlint happier
parent
8b1b7d15
Changes
38
Show 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
...
...
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