[refactoring] more record syntax rewriting

parent 2ce0bac3
......@@ -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"
......
......@@ -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
......
......@@ -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
]
......
......@@ -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
......
......@@ -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
......
......@@ -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 })
......@@ -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
......
......@@ -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"
......
......@@ -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_") ''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