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
acb9e74c
Commit
acb9e74c
authored
Feb 09, 2019
by
Alexandre Delanoë
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[FIX] Workflow.
parent
b625ade6
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
33 additions
and
24 deletions
+33
-24
Flow.hs
src/Gargantext/Database/Flow.hs
+32
-23
Node.hs
src/Gargantext/Database/Schema/Node.hs
+1
-1
No files found.
src/Gargantext/Database/Flow.hs
View file @
acb9e74c
...
...
@@ -14,6 +14,7 @@ Portability : POSIX
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
module
Gargantext.Database.Flow
-- (flowDatabase, ngrams2list)
where
...
...
@@ -54,19 +55,24 @@ import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
import
Gargantext.Prelude
import
Gargantext.Text.Parsers
(
parseDocs
,
FileFormat
)
import
System.FilePath
(
FilePath
)
import
Gargantext.API.Ngrams
(
HasRepoVar
)
import
Servant
(
ServantErr
)
import
Gargantext.API.Ngrams
(
NgramsElement
(
..
),
insertNewListOfNgramsElements
,
RepoCmdM
)
--import Gargantext.Database.Schema.User (insertUsers, simpleUser, gargantuaUser)
import
qualified
Data.Map
as
DM
type
FlowCmdM
env
err
m
=
(
CmdM
env
err
m
,
RepoCmdM
env
err
m
,
HasNodeError
err
,
HasRepoVar
env
)
flowCorpus
::
FlowCmdM
env
err
m
=>
FileFormat
->
FilePath
->
CorpusName
->
m
CorpusId
flowCorpus
::
FlowCmdM
env
ServantErr
m
=>
FileFormat
->
FilePath
->
CorpusName
->
m
CorpusId
flowCorpus
ff
fp
cName
=
do
--insertUsers [gargantuaUser, simpleUser]
hyperdataDocuments'
<-
map
addUniqIdsDoc
<$>
liftIO
(
parseDocs
ff
fp
)
params
<-
flowInsert
NodeCorpus
hyperdataDocuments'
cName
flowCorpus'
NodeCorpus
hyperdataDocuments'
params
...
...
@@ -86,7 +92,7 @@ flowInsert _nt hyperdataDocuments cName = do
pure
(
ids
,
masterUserId
,
masterCorpusId
,
userId
,
userCorpusId
)
flowAnnuaire
::
HasNodeError
err
=>
FilePath
->
Cmd
err
()
flowAnnuaire
::
FlowCmdM
env
ServantErr
m
=>
FilePath
->
m
()
flowAnnuaire
filePath
=
do
contacts
<-
liftIO
$
deserialiseImtUsersFromFile
filePath
ps
<-
flowInsertAnnuaire
"Annuaire"
$
map
(
\
h
->
ToDbContact
h
)
$
map
addUniqIdsContact
contacts
...
...
@@ -103,7 +109,7 @@ flowInsertAnnuaire name children = do
(
userId
,
_
,
userCorpusId
)
<-
subFlowAnnuaire
userArbitrary
name
_
<-
add
userCorpusId
(
map
reId
ids
)
--
printDebug "AnnuaireID" userCorpusId
printDebug
"AnnuaireID"
userCorpusId
pure
(
ids
,
masterUserId
,
masterCorpusId
,
userId
,
userCorpusId
)
...
...
@@ -118,26 +124,26 @@ flowCorpus' :: FlowCmdM env err m
=>
NodeType
->
[
HyperdataDocument
]
->
([
ReturnId
],
UserId
,
CorpusId
,
UserId
,
CorpusId
)
->
m
CorpusId
flowCorpus'
NodeCorpus
hyperdataDocuments
(
ids
,
_masterUserId
,
_
masterCorpusId
,
userId
,
userCorpusId
)
=
do
flowCorpus'
NodeCorpus
hyperdataDocuments
(
ids
,
masterUserId
,
masterCorpusId
,
userId
,
userCorpusId
)
=
do
--------------------------------------------------
-- List Ngrams Flow
_
userListId
<-
flowListUser
userId
userCorpusId
500
--
printDebug "Working on User ListId : " userListId
userListId
<-
flowListUser
userId
userCorpusId
500
printDebug
"Working on User ListId : "
userListId
let
documentsWithId
=
mergeData
(
toInserted
ids
)
(
toInsert
hyperdataDocuments
)
--
printDebug "documentsWithId" documentsWithId
printDebug
"documentsWithId"
documentsWithId
docsWithNgrams
<-
documentIdWithNgrams
extractNgramsT
documentsWithId
--
printDebug "docsWithNgrams" docsWithNgrams
printDebug
"docsWithNgrams"
docsWithNgrams
let
maps
=
mapNodeIdNgrams
docsWithNgrams
-- printDebug "maps" (maps)
terms2id
<-
insertNgrams
$
DM
.
keys
maps
let
indexedNgrams
=
DM
.
mapKeys
(
indexNgrams
terms2id
)
maps
--
printDebug "inserted ngrams" indexedNgrams
printDebug
"inserted ngrams"
indexedNgrams
_
<-
insertToNodeNgrams
indexedNgrams
--
listId2 <- flowList masterUserId masterCorpusId indexedNgrams
--
printDebug "Working on ListId : " listId2
listId2
<-
flowList
masterUserId
masterCorpusId
indexedNgrams
printDebug
"Working on ListId : "
listId2
--}
--------------------------------------------------
_
<-
mkDashboard
userCorpusId
userId
...
...
@@ -158,21 +164,24 @@ type CorpusName = Text
subFlowCorpus
::
HasNodeError
err
=>
Username
->
CorpusName
->
Cmd
err
(
UserId
,
RootId
,
CorpusId
)
subFlowCorpus
username
cName
=
do
maybeUserId
<-
getUser
username
userId
<-
case
maybeUserId
of
Nothing
->
nodeError
NoUserFound
-- mk NodeUser gargantua_id "Node Gargantua"
Just
user
->
pure
$
userLight_id
user
printDebug
"userId"
userId
rootId'
<-
map
_node_id
<$>
getRoot
username
printDebug
"rootId'"
rootId'
rootId''
<-
case
rootId'
of
[]
->
mkRoot
username
userId
n
->
case
length
n
>=
2
of
True
->
nodeError
ManyNodeUsers
False
->
pure
rootId'
rootId
<-
maybe
(
nodeError
NoRootFound
)
pure
(
head
rootId''
)
printDebug
"rootId''"
rootId''
rootId
<-
maybe
(
nodeError
NoRootFound
)
pure
(
head
rootId''
)
corpusId''
<-
if
username
==
userMaster
then
do
ns
<-
getCorporaWithParentId
rootId
...
...
@@ -186,8 +195,8 @@ subFlowCorpus username cName = do
corpusId
<-
maybe
(
nodeError
NoCorpusFound
)
pure
(
head
corpusId'
)
--
printDebug "(username, userId, rootId, corpusId)"
--
(username, userId, rootId, corpusId)
printDebug
"(username, userId, rootId, corpusId)"
(
username
,
userId
,
rootId
,
corpusId
)
pure
(
userId
,
rootId
,
corpusId
)
...
...
@@ -213,8 +222,8 @@ subFlowAnnuaire username _cName = do
corpusId
<-
maybe
(
nodeError
NoCorpusFound
)
pure
(
head
corpusId'
)
--
printDebug "(username, userId, rootId, corpusId)"
--
(username, userId, rootId, corpusId)
printDebug
"(username, userId, rootId, corpusId)"
(
username
,
userId
,
rootId
,
corpusId
)
pure
(
userId
,
rootId
,
corpusId
)
------------------------------------------------------------------------
...
...
@@ -283,18 +292,18 @@ mapNodeIdNgrams = DM.unionsWith (DM.unionWith (DM.unionWith (+))) . fmap f
------------------------------------------------------------------------
flowList
::
HasNodeError
err
=>
UserId
->
CorpusId
->
Map
NgramsIndexed
(
Map
NgramsType
(
Map
NodeId
Int
))
->
Cmd
err
ListId
flowList
uId
cId
_
ngs
=
do
flowList
uId
cId
ngs
=
do
-- printDebug "ngs:" ngs
lId
<-
getOrMkList
cId
uId
--
printDebug "ngs" (DM.keys ngs)
printDebug
"ngs"
(
DM
.
keys
ngs
)
-- TODO add stemming equivalence of 2 ngrams
-- TODO needs rework
-- let groupEd = groupNgramsBy (\(NgramsT t1 n1) (NgramsT t2 n2) -> if (((==) t1 t2) && ((==) n1 n2)) then (Just (n1,n2)) else Nothing) ngs
-- _ <- insertGroups lId groupEd
-- compute Candidate / Map
--
is <- insertLists lId $ ngrams2list ngs
--
printDebug "listNgrams inserted :" is
is
<-
insertLists
lId
$
ngrams2list
ngs
printDebug
"listNgrams inserted :"
is
pure
lId
...
...
src/Gargantext/Database/Schema/Node.hs
View file @
acb9e74c
...
...
@@ -512,7 +512,7 @@ type Name = Text
mkNodeWithParent
::
HasNodeError
err
=>
NodeType
->
Maybe
ParentId
->
UserId
->
Name
->
Cmd
err
[
NodeId
]
mkNodeWithParent
NodeUser
(
Just
_
)
_
_
=
nodeError
UserNoParent
mkNodeWithParent
_
Nothing
_
_
=
nodeError
HasParent
--
mkNodeWithParent _ Nothing _ _ = nodeError HasParent
mkNodeWithParent
nt
pId
uId
name
=
insertNodesWithParentR
pId
[
node
nt
name
hd
pId
uId
]
where
...
...
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