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   _mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
  92 {-
  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 -}
 100   -- Inserting groups of ngrams
 101   -- _r <- insert_Node_NodeNgrams_NodeNgrams
 102   --   $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
 103
 104   -- printDebug "flowList_Tficf':ngs" ngs
 105   listInsert lId ngs
 106
 107   --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
 108   pure lId
 109 ------------------------------------------------------------------------
 110 ------------------------------------------------------------------------
 111
 112 toNodeNgramsW :: ListId
 113               -> [(NgramsType, [NgramsElement])]
 114               -> [NodeNgramsW]
 115 toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
 116   where
 117     toNodeNgramsW'' :: ListId
 118                   -> (NgramsType, [NgramsElement])
 119                   -> [NodeNgramsW]
 120     toNodeNgramsW'' l' (ngrams_type, elms) =
 121       [ NodeNgrams { _nng_id            = Nothing
 122                    , _nng_node_id       = l'
 123                    , _nng_node_subtype  = list_type
 124                    , _nng_ngrams_id     = ngrams_terms'
 125                    , _nng_ngrams_type   = ngrams_type
 126                    , _nng_ngrams_field  = Nothing
 127                    , _nng_ngrams_tag    = Nothing
 128                    , _nng_ngrams_class  = Nothing
 129                    , _nng_ngrams_weight = 0 } |
 130        (NgramsElement { _ne_ngrams      = NgramsTerm ngrams_terms'
 131                       , _ne_size        = _size
 132                       , _ne_list        = list_type
 133                       , _ne_occurrences = _occ
 134                       , _ne_root        = _root
 135                       , _ne_parent      = _parent
 136                       , _ne_children    = _children
 137                       }
 138         ) <- elms
 139       ]
 140
 141
 142 toNodeNgramsW' :: ListId
 143                -> [(Text, [NgramsType])]
 144                -> [NodeNgramsW]
 145 toNodeNgramsW' l'' ngs = [ NodeNgrams { _nng_id            = Nothing
 146                                       , _nng_node_id       = l''
 147                                       , _nng_node_subtype  = CandidateTerm
 148                                       , _nng_ngrams_id     = terms
 149                                       , _nng_ngrams_type   = ngrams_type
 150                                       , _nng_ngrams_field  = Nothing
 151                                       , _nng_ngrams_tag    = Nothing
 152                                       , _nng_ngrams_class  = Nothing
 153                                       , _nng_ngrams_weight = 0
 154                                       }
 155                          | (terms, ngrams_types) <- ngs
 156                          , ngrams_type <- ngrams_types
 157                          ]
 158
 159
 160 listInsert :: FlowCmdM env err m
 161              => ListId
 162              -> Map NgramsType [NgramsElement]
 163              -> m ()
 164 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 165                              -> putListNgrams lId typeList ngElmts) (toList ngs)
 166
 167 ------------------------------------------------------------------------
 168 ------------------------------------------------------------------------
 169 -- NOTE
 170 -- This is no longer part of the API.
 171 -- This function is maintained for its usage in Database.Action.Flow.List.
 172 -- If the given list of ngrams elements contains ngrams already in
 173 -- the repo, they will be ignored.
 174 putListNgrams :: (HasInvalidError err, HasNodeStory env err m)
 175               => NodeId
 176               -> TableNgrams.NgramsType
 177               -> [NgramsElement]
 178               -> m ()
 179 putListNgrams _ _ [] = pure ()
 180 putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
 181   where
 182     m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
 183
 184     putListNgrams' :: (HasInvalidError err, HasNodeStory env err m)
 185                    => NodeId
 186                    -> TableNgrams.NgramsType
 187                    -> Map NgramsTerm NgramsRepoElement
 188                    -> m ()
 189     putListNgrams' listId ngramsType' ns = do
 190       -- printDebug "[putListNgrams'] nodeId" nodeId
 191       -- printDebug "[putListNgrams'] ngramsType" ngramsType
 192       -- printDebug "[putListNgrams'] ns" ns
 193
 194       let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
 195           (p, p_validity) = PM.singleton ngramsType' p1
 196       assertValid p_validity
 197       {-
 198       -- TODO
 199       v <- currentVersion
 200       q <- commitStatePatch (Versioned v p)
 201       assert empty q
 202       -- What if another commit comes in between?
 203       -- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
 204       -- The modifyMVar_ would test the patch with applicable first.
 205       -- If valid the rest would be atomic and no merge is required.
 206       -}
 207       var <- getNodeStoryVar [listId]
 208       liftBase $ modifyMVar_ var $ \r -> do
 209         pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
 210                  & unNodeStory . at listId . _Just . a_history %~ (p :)
 211                  & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
 212       saveNodeStory