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