]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Flow/List.hs
[MERGE] fix but weird behavior of git here, Nobody did push anything, I was last...
[gargantext.git] / src / Gargantext / Database / Flow / List.hs
1 {-|
2 Module : Gargantext.Database.Flow.List
3 Description : List Flow
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 -}
11
12 {-# OPTIONS_GHC -fno-warn-orphans #-}
13
14 {-# LANGUAGE ConstraintKinds #-}
15 {-# LANGUAGE RankNTypes #-}
16 {-# LANGUAGE ConstrainedClassMethods #-}
17 {-# LANGUAGE ConstraintKinds #-}
18 {-# LANGUAGE DeriveGeneric #-}
19 {-# LANGUAGE FlexibleContexts #-}
20 {-# LANGUAGE InstanceSigs #-}
21 {-# LANGUAGE NoImplicitPrelude #-}
22 {-# LANGUAGE OverloadedStrings #-}
23
24 module Gargantext.Database.Flow.List
25 where
26 import Data.Text (Text)
27 import Control.Monad (mapM_)
28 import Data.Map (Map, toList)
29 import Data.Maybe (Maybe(..), catMaybes)
30 import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams)
31 import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams, NgramsType(..), text2ngrams, ngramsTypeId)
32 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
33 import Gargantext.Database.Schema.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
34 import Gargantext.Database.Schema.Node_NodeNgramsNodeNgrams -- (insert_Node_NodeNgrams_NodeNgrams, Node_NodeNgrams_NodeNgrams(..))
35 import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
36 import Gargantext.Database.Flow.Types
37 import Gargantext.Prelude
38 import qualified Data.List as List
39 import qualified Data.Map as Map
40
41
42 -- FLOW LIST
43 -- | TODO check optimization
44 mapNodeIdNgrams :: [DocumentIdWithNgrams a]
45 -> Map Ngrams (Map NgramsType (Map NodeId Int))
46 mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
47 where
48 f :: DocumentIdWithNgrams a
49 -> Map Ngrams (Map NgramsType (Map NodeId Int))
50 f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
51 where
52 nId = documentId $ documentWithId d
53
54 ------------------------------------------------------------------------
55 flowList_DbRepo :: FlowCmdM env err m
56 => ListId
57 -> Map NgramsType [NgramsElement]
58 -> m ListId
59 flowList_DbRepo lId ngs = do
60 -- printDebug "listId flowList" lId
61 mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
62 let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> parent)
63 <*> getCgramsId mapCgramsId ntype ngram
64 | (ntype, ngs') <- Map.toList ngs
65 , NgramsElement ngram _ _ _ _ parent _ <- ngs'
66 ]
67 -- Inserting groups of ngrams
68 _r <- insert_Node_NodeNgrams_NodeNgrams
69 $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
70 listInsert lId ngs
71 --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
72 pure lId
73 ------------------------------------------------------------------------
74 ------------------------------------------------------------------------
75
76 toNodeNgramsW :: ListId
77 -> [(NgramsType, [NgramsElement])]
78 -> [NodeNgramsW]
79 toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
80 where
81 toNodeNgramsW'' :: ListId
82 -> (NgramsType, [NgramsElement])
83 -> [NodeNgramsW]
84 toNodeNgramsW'' l' (ngrams_type, elms) =
85 [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
86 (NgramsElement ngrams_terms' _size list_type _occ _root _parent _children) <- elms
87 ]
88
89 toNodeNgramsW' :: ListId
90 -> [(Text, [NgramsType])]
91 -> [NodeNgramsW]
92 toNodeNgramsW' l'' ngs = [ NodeNgrams Nothing l'' CandidateTerm terms ngrams_type Nothing Nothing Nothing 0
93 | (terms, ngrams_types) <- ngs
94 , ngrams_type <- ngrams_types
95 ]
96
97
98 listInsert :: FlowCmdM env err m
99 => ListId
100 -> Map NgramsType [NgramsElement]
101 -> m ()
102 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
103 -> putListNgrams lId typeList ngElmts
104 ) $ toList ngs
105 ------------------------------------------------------------------------
106 ------------------------------------------------------------------------
107