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