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