where
import Control.Concurrent
-import Control.Lens (view, (^.), (+~), (%~), at)
+import Control.Lens ((^.), (+~), (%~), at, (.~), _Just)
import Control.Monad.Reader
-import qualified Data.List as List
-import qualified Data.Map as Map
import Data.Map (Map, toList)
-import qualified Data.Map.Strict.Patch as PM
import Data.Maybe (catMaybes)
import Data.Text (Text)
-
-import Gargantext.API.Ngrams.Types (HasRepoSaver(..), NgramsElement(..), NgramsPatch(..), NgramsRepoElement(..), NgramsTablePatch(..), NgramsTerm(..), RepoCmdM, ne_ngrams, ngramsElementToRepo, r_history, r_state, r_version, repoVar)
-import Gargantext.Core.Flow.Types
+import Gargantext.API.Ngrams (saveNodeStory)
+import Gargantext.API.Ngrams.Tools (getNodeStoryVar)
+import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (HasInvalidError(..), assertValid)
import Gargantext.Core.Types.Main (ListType(CandidateTerm))
-import Gargantext.Core.Utils (something)
+import Gargantext.Core.NodeStory
import Gargantext.Database.Action.Flow.Types
-import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Query.Table.Node_NodeNgramsNodeNgrams
import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
--- import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams, NgramsType(..), text2ngrams, ngramsTypeId)
-import Gargantext.Database.Schema.Ngrams (Ngrams(..), NgramsType(..))
+import Gargantext.Database.Query.Table.Node_NodeNgramsNodeNgrams
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude
+import qualified Data.List as List
+import qualified Data.Map as Map
+import qualified Data.Map.Strict.Patch as PM
+import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
-- FLOW LIST
-- 1. select specific terms of the corpus when compared with others langs
-}
--- | TODO check optimization
-mapNodeIdNgrams :: [DocumentIdWithNgrams a]
- -> Map Ngrams (Map NgramsType (Map NodeId Int))
-mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
- where
- f :: DocumentIdWithNgrams a
- -> Map Ngrams (Map NgramsType (Map NodeId Int))
- f d = fmap (fmap (Map.singleton nId)) $ documentNgrams d
- where
- nId = documentId $ documentWithId d
-
------------------------------------------------------------------------
flowList_DbRepo :: FlowCmdM env err m
=> ListId
let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> (unNgramsTerm <$> parent))
<*> getCgramsId mapCgramsId ntype ngram
| (ntype, ngs') <- Map.toList ngs
- , NgramsElement (NgramsTerm ngram) _ _ _ _ parent _ <- ngs'
+ , NgramsElement { _ne_ngrams = NgramsTerm ngram
+ , _ne_parent = parent } <- ngs'
]
-- Inserting groups of ngrams
_r <- insert_Node_NodeNgrams_NodeNgrams
-> (NgramsType, [NgramsElement])
-> [NodeNgramsW]
toNodeNgramsW'' l' (ngrams_type, elms) =
- [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
- (NgramsElement (NgramsTerm ngrams_terms') _size list_type _occ _root _parent _children) <- elms
+ [ NodeNgrams { _nng_id = Nothing
+ , _nng_node_id = l'
+ , _nng_node_subtype = list_type
+ , _nng_ngrams_id = ngrams_terms'
+ , _nng_ngrams_type = ngrams_type
+ , _nng_ngrams_field = Nothing
+ , _nng_ngrams_tag = Nothing
+ , _nng_ngrams_class = Nothing
+ , _nng_ngrams_weight = 0 } |
+ (NgramsElement { _ne_ngrams = NgramsTerm ngrams_terms'
+ , _ne_size = _size
+ , _ne_list = list_type
+ , _ne_occurrences = _occ
+ , _ne_root = _root
+ , _ne_parent = _parent
+ , _ne_children = _children }) <- elms
]
toNodeNgramsW' :: ListId
-> [(Text, [NgramsType])]
-> [NodeNgramsW]
-toNodeNgramsW' l'' ngs = [ NodeNgrams Nothing l'' CandidateTerm terms ngrams_type Nothing Nothing Nothing 0
+toNodeNgramsW' l'' ngs = [ NodeNgrams { _nng_id = Nothing
+ , _nng_node_id = l''
+ , _nng_node_subtype = CandidateTerm
+ , _nng_ngrams_id = terms
+ , _nng_ngrams_type = ngrams_type
+ , _nng_ngrams_field = Nothing
+ , _nng_ngrams_tag = Nothing
+ , _nng_ngrams_class = Nothing
+ , _nng_ngrams_weight = 0 }
| (terms, ngrams_types) <- ngs
, ngrams_type <- ngrams_types
]
------------------------------------------------------------------------
------------------------------------------------------------------------
-
-
-- NOTE
-- This is no longer part of the API.
-- This function is maintained for its usage in Database.Action.Flow.List.
-- If the given list of ngrams elements contains ngrams already in
-- the repo, they will be ignored.
-putListNgrams :: (HasInvalidError err, RepoCmdM env err m)
+putListNgrams :: (HasInvalidError err, HasNodeStory env err m)
=> NodeId
-> TableNgrams.NgramsType
-> [NgramsElement]
where
m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
-putListNgrams' :: (HasInvalidError err, RepoCmdM env err m)
- => NodeId
- -> TableNgrams.NgramsType
- -> Map NgramsTerm NgramsRepoElement
- -> m ()
-putListNgrams' nodeId ngramsType ns = do
- -- printDebug "[putListNgrams'] nodeId" nodeId
- -- printDebug "[putListNgrams'] ngramsType" ngramsType
- -- printDebug "[putListNgrams'] ns" ns
-
- let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
- (p0, p0_validity) = PM.singleton nodeId p1
- (p, p_validity) = PM.singleton ngramsType p0
- assertValid p0_validity
- assertValid p_validity
- {-
- -- TODO
- v <- currentVersion
- q <- commitStatePatch (Versioned v p)
- assert empty q
- -- What if another commit comes in between?
- -- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
- -- The modifyMVar_ would test the patch with applicable first.
- -- If valid the rest would be atomic and no merge is required.
- -}
- var <- view repoVar
- liftBase $ modifyMVar_ var $ \r -> do
- pure $ r & r_version +~ 1
- & r_history %~ (p :)
- & r_state . at ngramsType %~
- (Just .
- (at nodeId %~
- ( Just
- . (<> ns)
- . something
- )
- )
- . something
- )
- saveRepo
-
-
-saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
- => m ()
-saveRepo = liftBase =<< view repoSaver
+ putListNgrams' :: (HasInvalidError err, HasNodeStory env err m)
+ => NodeId
+ -> TableNgrams.NgramsType
+ -> Map NgramsTerm NgramsRepoElement
+ -> m ()
+ putListNgrams' listId ngramsType' ns = do
+ -- printDebug "[putListNgrams'] nodeId" nodeId
+ -- printDebug "[putListNgrams'] ngramsType" ngramsType
+ -- printDebug "[putListNgrams'] ns" ns
+
+ let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
+ (p, p_validity) = PM.singleton ngramsType' p1
+ assertValid p_validity
+ {-
+ -- TODO
+ v <- currentVersion
+ q <- commitStatePatch (Versioned v p)
+ assert empty q
+ -- What if another commit comes in between?
+ -- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
+ -- The modifyMVar_ would test the patch with applicable first.
+ -- If valid the rest would be atomic and no merge is required.
+ -}
+ var <- getNodeStoryVar [listId]
+ liftBase $ modifyMVar_ var $ \r -> do
+ pure $ r & unNodeStory . at listId . _Just . a_version +~ 1
+ & unNodeStory . at listId . _Just . a_history %~ (p :)
+ & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
+ saveNodeStory
+