src/Gargantext/Database/Action/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 {-# LANGUAGE ConstraintKinds         #-}
  13 {-# LANGUAGE ConstrainedClassMethods #-}
  14 {-# LANGUAGE ConstraintKinds         #-}
  15 {-# LANGUAGE InstanceSigs            #-}
  16
  17 module Gargantext.Database.Action.Flow.List
  18     where
  19
  20 import Control.Concurrent
  21 import Control.Lens ((^.), (+~), (%~), at, (.~), _Just)
  22 import Control.Monad.Reader
  23 import Data.Map (Map, toList)
  24 import Data.Maybe (catMaybes)
  25 import Data.Text (Text)
  26 import Gargantext.API.Ngrams (saveNodeStory)
  27 import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
  28 import Gargantext.API.Ngrams.Types
  29 import Gargantext.Core.Types (HasInvalidError(..), assertValid)
  30 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
  31 import Gargantext.Core.NodeStory
  32 import Gargantext.Database.Action.Flow.Types
  33 import Gargantext.Database.Admin.Types.Node
  34 import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
  35 import Gargantext.Database.Query.Table.Node_NodeNgramsNodeNgrams
  36 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  37 import Gargantext.Prelude
  38 import qualified Data.List as List
  39 import qualified Data.Map  as Map
  40 import qualified Data.Map.Strict.Patch as PM
  41 import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
  42
  43 -- FLOW LIST
  44 -- 1. select specific terms of the corpus when compared with others langs
  45 -- (for now, suppose english)
  46 -- 2. select specific terms of the corpus when compared with others corpora (same database)
  47 -- 3. select clusters of terms (generic and specific)
  48
  49 {-
  50 data FlowList = FlowListLang
  51               | FlowListTficf
  52               | FlowListSpeGen
  53
  54
  55 flowList_Tficf :: UserCorpusId
  56                -> MasterCorpusId
  57                -> NgramsType
  58                -> (Text -> Text)
  59                -> Cmd err (Map Text (Double, Set Text))
  60 flowList_Tficf u m nt f = do
  61
  62   u' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsUser   u nt
  63   m' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsMaster u m
  64
  65   pure $ sortTficf Down
  66        $ toTficfData (countNodesByNgramsWith f u')
  67                      (countNodesByNgramsWith f m')
  68
  69 flowList_Tficf' :: UserCorpusId
  70                -> MasterCorpusId
  71                -> NgramsType
  72                -> Cmd err (Map Text (Double, Set Text))
  73 flowList_Tficf' u m nt f = do
  74
  75   u' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsUser   u nt
  76   m' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsMaster u m
  77
  78   pure $ sortTficf Down
  79        $ toTficfData (countNodesByNgramsWith f u')
  80                      (countNodesByNgramsWith f m')
  81
  82 -}
  83
  84
  85 ------------------------------------------------------------------------
  86 flowList_DbRepo :: FlowCmdM env err m
  87          => ListId
  88          -> Map NgramsType [NgramsElement]
  89          -> m ListId
  90 flowList_DbRepo lId ngs = do
  91   -- printDebug "listId flowList" lId
  92   mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
  93   let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> (unNgramsTerm <$> parent))
  94                                  <*>  getCgramsId mapCgramsId ntype ngram
  95                            | (ntype, ngs') <- Map.toList ngs
  96                            , NgramsElement { _ne_ngrams = NgramsTerm ngram
  97                                            , _ne_parent = parent } <- ngs'
  98                            ]
  99   -- Inserting groups of ngrams
 100   _r <- insert_Node_NodeNgrams_NodeNgrams
 101      $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
 102
 103   listInsert lId ngs
 104
 105   --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
 106   pure lId
 107 ------------------------------------------------------------------------
 108 ------------------------------------------------------------------------
 109
 110 toNodeNgramsW :: ListId
 111               -> [(NgramsType, [NgramsElement])]
 112               -> [NodeNgramsW]
 113 toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
 114   where
 115     toNodeNgramsW'' :: ListId
 116                   -> (NgramsType, [NgramsElement])
 117                   -> [NodeNgramsW]
 118     toNodeNgramsW'' l' (ngrams_type, elms) =
 119       [ NodeNgrams { _nng_id = Nothing
 120                    , _nng_node_id = l'
 121                    , _nng_node_subtype = list_type
 122                    , _nng_ngrams_id = ngrams_terms'
 123                    , _nng_ngrams_type = ngrams_type
 124                    , _nng_ngrams_field = Nothing
 125                    , _nng_ngrams_tag = Nothing
 126                    , _nng_ngrams_class = Nothing
 127                    , _nng_ngrams_weight = 0 } |
 128        (NgramsElement { _ne_ngrams = NgramsTerm ngrams_terms'
 129                       , _ne_size = _size
 130                       , _ne_list = list_type
 131                       , _ne_occurrences = _occ
 132                       , _ne_root = _root
 133                       , _ne_parent = _parent
 134                       , _ne_children = _children }) <- elms
 135       ]
 136
 137
 138 toNodeNgramsW' :: ListId
 139                -> [(Text, [NgramsType])]
 140                -> [NodeNgramsW]
 141 toNodeNgramsW' l'' ngs = [ NodeNgrams { _nng_id = Nothing
 142                                       , _nng_node_id = l''
 143                                       , _nng_node_subtype = CandidateTerm
 144                                       , _nng_ngrams_id = terms
 145                                       , _nng_ngrams_type = ngrams_type
 146                                       , _nng_ngrams_field = Nothing
 147                                       , _nng_ngrams_tag = Nothing
 148                                       , _nng_ngrams_class = Nothing
 149                                       , _nng_ngrams_weight = 0 }
 150                          | (terms, ngrams_types) <- ngs
 151                          , ngrams_type <- ngrams_types
 152                          ]
 153
 154
 155 listInsert :: FlowCmdM env err m
 156              => ListId
 157              -> Map NgramsType [NgramsElement]
 158              -> m ()
 159 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 160                              -> putListNgrams lId typeList ngElmts) (toList ngs)
 161
 162 ------------------------------------------------------------------------
 163 ------------------------------------------------------------------------
 164 -- NOTE
 165 -- This is no longer part of the API.
 166 -- This function is maintained for its usage in Database.Action.Flow.List.
 167 -- If the given list of ngrams elements contains ngrams already in
 168 -- the repo, they will be ignored.
 169 putListNgrams :: (HasInvalidError err, HasNodeStory env err m)
 170               => NodeId
 171               -> TableNgrams.NgramsType
 172               -> [NgramsElement]
 173               -> m ()
 174 putListNgrams _ _ [] = pure ()
 175 putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
 176   where
 177     m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
 178
 179     putListNgrams' :: (HasInvalidError err, HasNodeStory env err m)
 180                    => NodeId
 181                    -> TableNgrams.NgramsType
 182                    -> Map NgramsTerm NgramsRepoElement
 183                    -> m ()
 184     putListNgrams' listId ngramsType' ns = do
 185       -- printDebug "[putListNgrams'] nodeId" nodeId
 186       -- printDebug "[putListNgrams'] ngramsType" ngramsType
 187       -- printDebug "[putListNgrams'] ns" ns
 188
 189       let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
 190           (p, p_validity) = PM.singleton ngramsType' p1
 191       assertValid p_validity
 192       {-
 193       -- TODO
 194       v <- currentVersion
 195       q <- commitStatePatch (Versioned v p)
 196       assert empty q
 197       -- What if another commit comes in between?
 198       -- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
 199       -- The modifyMVar_ would test the patch with applicable first.
 200       -- If valid the rest would be atomic and no merge is required.
 201       -}
 202       var <- getNodeStoryVar [listId]
 203       liftBase $ modifyMVar_ var $ \r -> do
 204         pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
 205                  & unNodeStory . at listId . _Just . a_history %~ (p :)
 206                  & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
 207       saveNodeStory
 208