[refactoring] more record syntax rewriting

parent 2ce0bac3
...@@ -111,7 +111,10 @@ updateScatter' cId maybeListId tabType maybeLimit = do ...@@ -111,7 +111,10 @@ updateScatter' cId maybeListId tabType maybeLimit = do
(ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
let 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 $ fmap normalizeLocal scores
listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m listType t m = maybe (panic errorMsg) fst $ HashMap.lookup t m
errorMsg = "API.Node.metrics: key absent" errorMsg = "API.Node.metrics: key absent"
......
...@@ -315,7 +315,10 @@ type PairWith = Summary "Pair a Corpus with an Annuaire" ...@@ -315,7 +315,10 @@ type PairWith = Summary "Pair a Corpus with an Annuaire"
pairWith :: CorpusId -> GargServer PairWith pairWith :: CorpusId -> GargServer PairWith
pairWith cId aId lId = do pairWith cId aId lId = do
r <- pairing cId aId lId 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 pure r
......
...@@ -93,7 +93,8 @@ flowList_DbRepo lId ngs = do ...@@ -93,7 +93,8 @@ flowList_DbRepo lId ngs = do
let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> (unNgramsTerm <$> parent)) let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> (unNgramsTerm <$> parent))
<*> getCgramsId mapCgramsId ntype ngram <*> getCgramsId mapCgramsId ntype ngram
| (ntype, ngs') <- Map.toList ngs | (ntype, ngs') <- Map.toList ngs
, NgramsElement (NgramsTerm ngram) _ _ _ _ parent _ <- ngs' , NgramsElement { _ne_ngrams = NgramsTerm ngram
, _ne_parent = parent } <- ngs'
] ]
-- Inserting groups of ngrams -- Inserting groups of ngrams
_r <- insert_Node_NodeNgrams_NodeNgrams _r <- insert_Node_NodeNgrams_NodeNgrams
...@@ -115,15 +116,37 @@ toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs ...@@ -115,15 +116,37 @@ toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
-> (NgramsType, [NgramsElement]) -> (NgramsType, [NgramsElement])
-> [NodeNgramsW] -> [NodeNgramsW]
toNodeNgramsW'' l' (ngrams_type, elms) = toNodeNgramsW'' l' (ngrams_type, elms) =
[ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 | [ NodeNgrams { _nng_id = Nothing
(NgramsElement (NgramsTerm ngrams_terms') _size list_type _occ _root _parent _children) <- elms , _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 toNodeNgramsW' :: ListId
-> [(Text, [NgramsType])] -> [(Text, [NgramsType])]
-> [NodeNgramsW] -> [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 | (terms, ngrams_types) <- ngs
, ngrams_type <- ngrams_types , ngrams_type <- ngrams_types
] ]
......
...@@ -72,7 +72,10 @@ pairing a c l' = do ...@@ -72,7 +72,10 @@ pairing a c l' = do
Just l'' -> pure l'' Just l'' -> pure l''
dataPaired <- dataPairing a (c,l,Authors) takeName takeName dataPaired <- dataPairing a (c,l,Authors) takeName takeName
r <- insertDB $ prepareInsert dataPaired 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 pure r
...@@ -96,7 +99,10 @@ dataPairing aId (cId, lId, ngt) fc fa = do ...@@ -96,7 +99,10 @@ dataPairing aId (cId, lId, ngt) fc fa = do
prepareInsert :: HashMap ContactId (Set DocId) -> [NodeNode] 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 $ List.concat
$ map (\(contactId, setDocIds) $ map (\(contactId, setDocIds)
-> map (\setDocId -> map (\setDocId
......
...@@ -54,7 +54,10 @@ insertDocNgrams :: CorpusId ...@@ -54,7 +54,10 @@ insertDocNgrams :: CorpusId
-> HashMap (Indexed Int Ngrams) (Map NgramsType (Map NodeId Int)) -> HashMap (Indexed Int Ngrams) (Map NgramsType (Map NodeId Int))
-> Cmd err Int -> Cmd err Int
insertDocNgrams cId m = 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 | (ng, t2n2i) <- HashMap.toList m
, (t, n2i) <- DM.toList t2n2i , (t, n2i) <- DM.toList t2n2i
, (n, i) <- DM.toList n2i , (n, i) <- DM.toList n2i
......
...@@ -29,5 +29,6 @@ sendMail :: HasNodeError err => User -> Cmd err () ...@@ -29,5 +29,6 @@ sendMail :: HasNodeError err => User -> Cmd err ()
sendMail u = do sendMail u = do
server <- view $ hasConfig . gc_url server <- view $ hasConfig . gc_url
userLight <- getUserLightDB u 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 })
...@@ -92,13 +92,13 @@ queryInCorpus cId t q = proc () -> do ...@@ -92,13 +92,13 @@ queryInCorpus cId t q = proc () -> do
else (nn^.nn_category) .>= (toNullable $ pgInt4 1) else (nn^.nn_category) .>= (toNullable $ pgInt4 1)
restrict -< (n ^. ns_search) @@ (pgTSQuery (unpack q)) restrict -< (n ^. ns_search) @@ (pgTSQuery (unpack q))
restrict -< (n ^. ns_typename ) .== (pgInt4 $ toDBid NodeDocument) restrict -< (n ^. ns_typename ) .== (pgInt4 $ toDBid NodeDocument)
returnA -< FacetDoc (n^.ns_id ) returnA -< FacetDoc { facetDoc_id = n^.ns_id
(n^.ns_date ) , facetDoc_created = n^.ns_date
(n^.ns_name ) , facetDoc_title = n^.ns_name
(n^.ns_hyperdata ) , facetDoc_hyperdata = n^.ns_hyperdata
(nn^.nn_category ) , facetDoc_category = nn^.nn_category
(nn^.nn_score ) , facetDoc_ngramCount = nn^.nn_score
(nn^.nn_score ) , facetDoc_score = nn^.nn_score }
joinInCorpus :: O.Query (NodeSearchRead, NodeNodeReadNull) joinInCorpus :: O.Query (NodeSearchRead, NodeNodeReadNull)
joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
...@@ -156,7 +156,10 @@ selectGroup :: HasDBid NodeType ...@@ -156,7 +156,10 @@ selectGroup :: HasDBid NodeType
selectGroup cId aId q = proc () -> do selectGroup cId aId q = proc () -> do
(a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum)) (a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
(selectContactViaDoc cId aId q) -< () (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 queryContactViaDoc :: O.Query ( NodeSearchRead
...@@ -270,7 +273,7 @@ textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year' \ ...@@ -270,7 +273,7 @@ textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year' \
textSearch :: HasDBid NodeType textSearch :: HasDBid NodeType
=> TSQuery -> ParentId => TSQuery -> ParentId
-> Limit -> Offset -> Order -> 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) textSearch q p l o ord = runPGSQuery textSearchQuery (q,p,p,typeId,ord,o,l)
where where
typeId = toDBid NodeDocument typeId = toDBid NodeDocument
......
...@@ -53,7 +53,10 @@ shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do ...@@ -53,7 +53,10 @@ shareNodeWith (ShareNodeWith_User NodeFolderShared u) n = do
then errorWith "[G.D.A.S.shareNodeWith] Can share to others only" then errorWith "[G.D.A.S.shareNodeWith] Can share to others only"
else do else do
folderSharedId <- getFolderId u NodeFolderShared 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 shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
nodeToCheck <- getNode n nodeToCheck <- getNode n
...@@ -63,7 +66,10 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do ...@@ -63,7 +66,10 @@ shareNodeWith (ShareNodeWith_Node NodeFolderPublic nId) n = do
else do else do
folderToCheck <- getNode nId folderToCheck <- getNode nId
if hasNodeType folderToCheck NodeFolderPublic 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" else errorWith "[G.D.A.S.shareNodeWith] Can share NodeWith NodeFolderPublic only"
shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType" shareNodeWith _ _ = errorWith "[G.D.A.S.shareNodeWith] Not implemented for this NodeType"
......
...@@ -118,11 +118,11 @@ instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where ...@@ -118,11 +118,11 @@ instance (Arbitrary i, Arbitrary l) => Arbitrary (Pair i l) where
arbitrary = Pair <$> arbitrary <*> arbitrary arbitrary = Pair <$> arbitrary <*> arbitrary
data FacetPaired id date hyperdata score = data FacetPaired id date hyperdata score =
FacetPaired {_fp_id :: id FacetPaired { _fp_id :: id
,_fp_date :: date , _fp_date :: date
,_fp_hyperdata :: hyperdata , _fp_hyperdata :: hyperdata
,_fp_score :: score , _fp_score :: score }
} deriving (Show, Generic) deriving (Show, Generic)
$(deriveJSON (unPrefix "_fp_") ''FacetPaired) $(deriveJSON (unPrefix "_fp_") ''FacetPaired)
$(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired) $(makeAdaptorAndInstance "pFacetPaired" ''FacetPaired)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment