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.Maybe (catMaybes)
  25 import Data.Text (Text)
  26 import Gargantext.API.Ngrams (saveNodeStory)
  27 import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
  28 import Gargantext.API.Ngrams.Types
  29 import Gargantext.Core.Types (HasInvalidError(..), assertValid)
  30 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
  31 import Gargantext.Core.NodeStory
  32 import Gargantext.Database.Action.Flow.Types
  33 import Gargantext.Database.Admin.Types.Node
  34 import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
  35 import Gargantext.Database.Query.Table.Node_NodeNgramsNodeNgrams
  36 import Gargantext.Database.Schema.Ngrams (NgramsType(..))
  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 -- 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, HasNodeStory 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, HasNodeStory env err m)
 157                    => NodeId
 158                    -> TableNgrams.NgramsType
 159                    -> Map NgramsTerm NgramsRepoElement
 160                    -> m ()
 161     putListNgrams' listId 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           (p, p_validity) = PM.singleton ngramsType' p1
 168       assertValid p_validity
 169       {-
 170       -- TODO
 171       v <- currentVersion
 172       q <- commitStatePatch (Versioned v p)
 173       assert empty q
 174       -- What if another commit comes in between?
 175       -- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
 176       -- The modifyMVar_ would test the patch with applicable first.
 177       -- If valid the rest would be atomic and no merge is required.
 178       -}
 179       var <- getNodeStoryVar [listId]
 180       liftBase $ modifyMVar_ var $ \r -> do
 181         pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
 182                  & unNodeStory . at listId . _Just . a_history %~ (p :)
 183                  & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
 184       saveNodeStory
 185