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 (view, (^.), (+~), (%~), at)
  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.Types (HasRepoSaver(..), NgramsElement(..), NgramsPatch(..), NgramsRepoElement(..), NgramsTablePatch(..), NgramsTerm(..), RepoCmdM, ne_ngrams, ngramsElementToRepo, r_history, r_state, r_version, repoVar)
  27 import Gargantext.Core.Types (HasInvalidError(..), assertValid)
  28 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
  29 import Gargantext.Core.Utils (something)
  30 import Gargantext.Database.Action.Flow.Types
  31 import Gargantext.Database.Action.Flow.Utils (DocumentIdWithNgrams(..))
  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 (Ngrams(..), NgramsType(..))
  36 import Gargantext.Database.Types
  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 (NgramsTerm ngram) _ _ _ _ parent _ <- ngs'
  97                            ]
  98   -- Inserting groups of ngrams
  99   _r <- insert_Node_NodeNgrams_NodeNgrams
 100      $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
 101
 102   listInsert lId ngs
 103
 104   --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
 105   pure lId
 106 ------------------------------------------------------------------------
 107 ------------------------------------------------------------------------
 108
 109 toNodeNgramsW :: ListId
 110               -> [(NgramsType, [NgramsElement])]
 111               -> [NodeNgramsW]
 112 toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
 113   where
 114     toNodeNgramsW'' :: ListId
 115                   -> (NgramsType, [NgramsElement])
 116                   -> [NodeNgramsW]
 117     toNodeNgramsW'' l' (ngrams_type, elms) =
 118       [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
 119        (NgramsElement (NgramsTerm ngrams_terms') _size list_type _occ _root _parent _children) <- elms
 120       ]
 121
 122
 123 toNodeNgramsW' :: ListId
 124                -> [(Text, [NgramsType])]
 125                -> [NodeNgramsW]
 126 toNodeNgramsW' l'' ngs = [ NodeNgrams Nothing l'' CandidateTerm terms ngrams_type Nothing Nothing Nothing 0
 127                          | (terms, ngrams_types) <- ngs
 128                          , ngrams_type <- ngrams_types
 129                          ]
 130
 131
 132 listInsert :: FlowCmdM env err m
 133              => ListId
 134              -> Map NgramsType [NgramsElement]
 135              -> m ()
 136 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 137                              -> putListNgrams lId typeList ngElmts) (toList ngs)
 138
 139 ------------------------------------------------------------------------
 140 ------------------------------------------------------------------------
 141
 142
 143 -- NOTE
 144 -- This is no longer part of the API.
 145 -- This function is maintained for its usage in Database.Action.Flow.List.
 146 -- If the given list of ngrams elements contains ngrams already in
 147 -- the repo, they will be ignored.
 148 putListNgrams :: (HasInvalidError err, RepoCmdM env err m)
 149               => NodeId
 150               -> TableNgrams.NgramsType
 151               -> [NgramsElement]
 152               -> m ()
 153 putListNgrams _ _ [] = pure ()
 154 putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
 155   where
 156     m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
 157
 158 putListNgrams' :: (HasInvalidError err, RepoCmdM env err m)
 159                => NodeId
 160                -> TableNgrams.NgramsType
 161                -> Map NgramsTerm NgramsRepoElement
 162                -> m ()
 163 putListNgrams' nodeId ngramsType ns = do
 164   -- printDebug "[putListNgrams'] nodeId" nodeId
 165   -- printDebug "[putListNgrams'] ngramsType" ngramsType
 166   -- printDebug "[putListNgrams'] ns" ns
 167
 168   let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
 169       (p0, p0_validity) = PM.singleton nodeId p1
 170       (p, p_validity) = PM.singleton ngramsType p0
 171   assertValid p0_validity
 172   assertValid p_validity
 173   {-
 174   -- TODO
 175   v <- currentVersion
 176   q <- commitStatePatch (Versioned v p)
 177   assert empty q
 178   -- What if another commit comes in between?
 179   -- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
 180   -- The modifyMVar_ would test the patch with applicable first.
 181   -- If valid the rest would be atomic and no merge is required.
 182   -}
 183   var <- view repoVar
 184   liftBase $ modifyMVar_ var $ \r -> do
 185     pure $ r & r_version +~ 1
 186              & r_history %~ (p :)
 187              & r_state . at ngramsType %~
 188                (Just .
 189                  (at nodeId %~
 190                    ( Just
 191                    . (<> ns)
 192                    . something
 193                    )
 194                  )
 195                  . something
 196                )
 197   saveRepo
 198
 199
 200 saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
 201          => m ()
 202 saveRepo = liftBase =<< view repoSaver