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