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
477a7fdc
Verified
Commit
477a7fdc
authored
Sep 14, 2021
by
Przemyslaw Kaminski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[refactoring] more record syntax rewriting
parent
2ce0bac3
Changes
9
Hide whitespace changes
Inline
Side-by-side
Showing
9 changed files
with
74 additions
and
26 deletions
+74
-26
Metrics.hs
src/Gargantext/API/Metrics.hs
+4
-1
Node.hs
src/Gargantext/API/Node.hs
+4
-1
List.hs
src/Gargantext/Database/Action/Flow/List.hs
+27
-4
Pairing.hs
src/Gargantext/Database/Action/Flow/Pairing.hs
+8
-2
Utils.hs
src/Gargantext/Database/Action/Flow/Utils.hs
+4
-1
Mail.hs
src/Gargantext/Database/Action/Mail.hs
+2
-1
Search.hs
src/Gargantext/Database/Action/Search.hs
+12
-9
Share.hs
src/Gargantext/Database/Action/Share.hs
+8
-2
Facet.hs
src/Gargantext/Database/Query/Facet.hs
+5
-5
No files found.
src/Gargantext/API/Metrics.hs
View file @
477a7fdc
...
...
@@ -111,7 +111,10 @@ updateScatter' cId maybeListId tabType maybeLimit = do
(
ngs'
,
scores
)
<-
Metrics
.
getMetrics
cId
maybeListId
tabType
maybeLimit
let
metrics
=
fmap
(
\
(
Scored
t
s1
s2
)
->
Metric
(
unNgramsTerm
t
)
s1
s2
(
listType
t
ngs'
))
metrics
=
fmap
(
\
(
Scored
t
s1
s2
)
->
Metric
{
m_label
=
unNgramsTerm
t
,
m_x
=
s1
,
m_y
=
s2
,
m_cat
=
listType
t
ngs'
})
$
fmap
normalizeLocal
scores
listType
t
m
=
maybe
(
panic
errorMsg
)
fst
$
HashMap
.
lookup
t
m
errorMsg
=
"API.Node.metrics: key absent"
...
...
src/Gargantext/API/Node.hs
View file @
477a7fdc
...
...
@@ -315,7 +315,10 @@ type PairWith = Summary "Pair a Corpus with an Annuaire"
pairWith
::
CorpusId
->
GargServer
PairWith
pairWith
cId
aId
lId
=
do
r
<-
pairing
cId
aId
lId
_
<-
insertNodeNode
[
NodeNode
cId
aId
Nothing
Nothing
]
_
<-
insertNodeNode
[
NodeNode
{
_nn_node1_id
=
cId
,
_nn_node2_id
=
aId
,
_nn_score
=
Nothing
,
_nn_category
=
Nothing
}]
pure
r
...
...
src/Gargantext/Database/Action/Flow/List.hs
View file @
477a7fdc
...
...
@@ -93,7 +93,8 @@ flowList_DbRepo lId ngs = do
let
toInsert
=
catMaybes
[
(,)
<$>
(
getCgramsId
mapCgramsId
ntype
<$>
(
unNgramsTerm
<$>
parent
))
<*>
getCgramsId
mapCgramsId
ntype
ngram
|
(
ntype
,
ngs'
)
<-
Map
.
toList
ngs
,
NgramsElement
(
NgramsTerm
ngram
)
_
_
_
_
parent
_
<-
ngs'
,
NgramsElement
{
_ne_ngrams
=
NgramsTerm
ngram
,
_ne_parent
=
parent
}
<-
ngs'
]
-- Inserting groups of ngrams
_r
<-
insert_Node_NodeNgrams_NodeNgrams
...
...
@@ -115,15 +116,37 @@ toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
->
(
NgramsType
,
[
NgramsElement
])
->
[
NodeNgramsW
]
toNodeNgramsW''
l'
(
ngrams_type
,
elms
)
=
[
NodeNgrams
Nothing
l'
list_type
ngrams_terms'
ngrams_type
Nothing
Nothing
Nothing
0
|
(
NgramsElement
(
NgramsTerm
ngrams_terms'
)
_size
list_type
_occ
_root
_parent
_children
)
<-
elms
[
NodeNgrams
{
_nng_id
=
Nothing
,
_nng_node_id
=
l'
,
_nng_node_subtype
=
list_type
,
_nng_ngrams_id
=
ngrams_terms'
,
_nng_ngrams_type
=
ngrams_type
,
_nng_ngrams_field
=
Nothing
,
_nng_ngrams_tag
=
Nothing
,
_nng_ngrams_class
=
Nothing
,
_nng_ngrams_weight
=
0
}
|
(
NgramsElement
{
_ne_ngrams
=
NgramsTerm
ngrams_terms'
,
_ne_size
=
_size
,
_ne_list
=
list_type
,
_ne_occurrences
=
_occ
,
_ne_root
=
_root
,
_ne_parent
=
_parent
,
_ne_children
=
_children
})
<-
elms
]
toNodeNgramsW'
::
ListId
->
[(
Text
,
[
NgramsType
])]
->
[
NodeNgramsW
]
toNodeNgramsW'
l''
ngs
=
[
NodeNgrams
Nothing
l''
CandidateTerm
terms
ngrams_type
Nothing
Nothing
Nothing
0
toNodeNgramsW'
l''
ngs
=
[
NodeNgrams
{
_nng_id
=
Nothing
,
_nng_node_id
=
l''
,
_nng_node_subtype
=
CandidateTerm
,
_nng_ngrams_id
=
terms
,
_nng_ngrams_type
=
ngrams_type
,
_nng_ngrams_field
=
Nothing
,
_nng_ngrams_tag
=
Nothing
,
_nng_ngrams_class
=
Nothing
,
_nng_ngrams_weight
=
0
}
|
(
terms
,
ngrams_types
)
<-
ngs
,
ngrams_type
<-
ngrams_types
]
...
...
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @
477a7fdc
...
...
@@ -72,7 +72,10 @@ pairing a c l' = do
Just
l''
->
pure
l''
dataPaired
<-
dataPairing
a
(
c
,
l
,
Authors
)
takeName
takeName
r
<-
insertDB
$
prepareInsert
dataPaired
_
<-
insertNodeNode
[
NodeNode
c
a
Nothing
Nothing
]
_
<-
insertNodeNode
[
NodeNode
{
_nn_node1_id
=
c
,
_nn_node2_id
=
a
,
_nn_score
=
Nothing
,
_nn_category
=
Nothing
}]
pure
r
...
...
@@ -96,7 +99,10 @@ dataPairing aId (cId, lId, ngt) fc fa = do
prepareInsert
::
HashMap
ContactId
(
Set
DocId
)
->
[
NodeNode
]
prepareInsert
m
=
map
(
\
(
n1
,
n2
)
->
NodeNode
n1
n2
Nothing
Nothing
)
prepareInsert
m
=
map
(
\
(
n1
,
n2
)
->
NodeNode
{
_nn_node1_id
=
n1
,
_nn_node2_id
=
n2
,
_nn_score
=
Nothing
,
_nn_category
=
Nothing
})
$
List
.
concat
$
map
(
\
(
contactId
,
setDocIds
)
->
map
(
\
setDocId
...
...
src/Gargantext/Database/Action/Flow/Utils.hs
View file @
477a7fdc
...
...
@@ -54,7 +54,10 @@ insertDocNgrams :: CorpusId
->
HashMap
(
Indexed
Int
Ngrams
)
(
Map
NgramsType
(
Map
NodeId
Int
))
->
Cmd
err
Int
insertDocNgrams
cId
m
=
insertDocNgramsOn
cId
[
DocNgrams
n
(
_index
ng
)
(
ngramsTypeId
t
)
(
fromIntegral
i
)
insertDocNgramsOn
cId
[
DocNgrams
{
dn_doc_id
=
n
,
dn_ngrams_id
=
_index
ng
,
dn_ngrams_type
=
ngramsTypeId
t
,
dn_weight
=
fromIntegral
i
}
|
(
ng
,
t2n2i
)
<-
HashMap
.
toList
m
,
(
t
,
n2i
)
<-
DM
.
toList
t2n2i
,
(
n
,
i
)
<-
DM
.
toList
n2i
...
...
src/Gargantext/Database/Action/Mail.hs
View file @
477a7fdc
...
...
@@ -29,5 +29,6 @@ sendMail :: HasNodeError err => User -> Cmd err ()
sendMail
u
=
do
server
<-
view
$
hasConfig
.
gc_url
userLight
<-
getUserLightDB
u
liftBase
$
mail
server
(
MailInfo
(
userLight_username
userLight
)
(
userLight_email
userLight
))
liftBase
$
mail
server
(
MailInfo
{
mailInfo_username
=
userLight_username
userLight
,
mailInfo_address
=
userLight_email
userLight
})
src/Gargantext/Database/Action/Search.hs
View file @
477a7fdc
...
...
@@ -92,13 +92,13 @@ queryInCorpus cId t q = proc () -> do
else
(
nn
^.
nn_category
)
.>=
(
toNullable
$
pgInt4
1
)
restrict
-<
(
n
^.
ns_search
)
@@
(
pgTSQuery
(
unpack
q
))
restrict
-<
(
n
^.
ns_typename
)
.==
(
pgInt4
$
toDBid
NodeDocument
)
returnA
-<
FacetDoc
(
n
^.
ns_id
)
(
n
^.
ns_date
)
(
n
^.
ns_name
)
(
n
^.
ns_hyperdata
)
(
nn
^.
nn_category
)
(
nn
^.
nn_score
)
(
nn
^.
nn_score
)
returnA
-<
FacetDoc
{
facetDoc_id
=
n
^.
ns_id
,
facetDoc_created
=
n
^.
ns_date
,
facetDoc_title
=
n
^.
ns_name
,
facetDoc_hyperdata
=
n
^.
ns_hyperdata
,
facetDoc_category
=
nn
^.
nn_category
,
facetDoc_ngramCount
=
nn
^.
nn_score
,
facetDoc_score
=
nn
^.
nn_score
}
joinInCorpus
::
O
.
Query
(
NodeSearchRead
,
NodeNodeReadNull
)
joinInCorpus
=
leftJoin
queryNodeSearchTable
queryNodeNodeTable
cond
...
...
@@ -156,7 +156,10 @@ selectGroup :: HasDBid NodeType
selectGroup
cId
aId
q
=
proc
()
->
do
(
a
,
b
,
c
,
d
)
<-
aggregate
(
p4
(
groupBy
,
groupBy
,
groupBy
,
O
.
sum
))
(
selectContactViaDoc
cId
aId
q
)
-<
()
returnA
-<
FacetPaired
a
b
c
d
returnA
-<
FacetPaired
{
_fp_id
=
a
,
_fp_date
=
b
,
_fp_hyperdata
=
c
,
_fp_score
=
d
}
queryContactViaDoc
::
O
.
Query
(
NodeSearchRead
...
...
@@ -270,7 +273,7 @@ textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year' \
textSearch
::
HasDBid
NodeType
=>
TSQuery
->
ParentId
->
Limit
->
Offset
->
Order
->
Cmd
err
[(
Int
,
Value
,
Value
,
Value
,
Value
,
Maybe
Int
)]
->
Cmd
err
[(
Int
,
Value
,
Value
,
Value
,
Value
,
Maybe
Int
)]
textSearch
q
p
l
o
ord
=
runPGSQuery
textSearchQuery
(
q
,
p
,
p
,
typeId
,
ord
,
o
,
l
)
where
typeId
=
toDBid
NodeDocument
...
...
src/Gargantext/Database/Action/Share.hs
View file @
477a7fdc
...
...
@@ -53,7 +53,10 @@ shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
then
errorWith
"[G.D.A.S.shareNodeWith] Can share to others only"
else
do
folderSharedId
<-
getFolderId
u
NodeFolderShared
insertDB
([
NodeNode
folderSharedId
n
Nothing
Nothing
]
::
[
NodeNode
])
insertDB
([
NodeNode
{
_nn_node1_id
=
folderSharedId
,
_nn_node2_id
=
n
,
_nn_score
=
Nothing
,
_nn_category
=
Nothing
}]
::
[
NodeNode
])
shareNodeWith
(
ShareNodeWith_Node
NodeFolderPublic
nId
)
n
=
do
nodeToCheck
<-
getNode
n
...
...
@@ -63,7 +66,10 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
else
do
folderToCheck
<-
getNode
nId
if
hasNodeType
folderToCheck
NodeFolderPublic
then
insertDB
([
NodeNode
nId
n
Nothing
Nothing
]
::
[
NodeNode
])
then
insertDB
([
NodeNode
{
_nn_node1_id
=
nId
,
_nn_node2_id
=
n
,
_nn_score
=
Nothing
,
_nn_category
=
Nothing
}]
::
[
NodeNode
])
else
errorWith
"[G.D.A.S.shareNodeWith] Can share NodeWith NodeFolderPublic only"
shareNodeWith
_
_
=
errorWith
"[G.D.A.S.shareNodeWith] Not implemented for this NodeType"
...
...
src/Gargantext/Database/Query/Facet.hs
View file @
477a7fdc
...
...
@@ -118,11 +118,11 @@ instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
arbitrary
=
Pair
<$>
arbitrary
<*>
arbitrary
data
FacetPaired
id
date
hyperdata
score
=
FacetPaired
{
_fp_id
::
id
,
_fp_date
::
date
,
_fp_hyperdata
::
hyperdata
,
_fp_score
::
score
}
deriving
(
Show
,
Generic
)
FacetPaired
{
_fp_id
::
id
,
_fp_date
::
date
,
_fp_hyperdata
::
hyperdata
,
_fp_score
::
score
}
deriving
(
Show
,
Generic
)
$
(
deriveJSON
(
unPrefix
"_fp_"
)
''
F
acetPaired
)
$
(
makeAdaptorAndInstance
"pFacetPaired"
''
F
acetPaired
)
...
...
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