Stability : experimental
Portability : POSIX
-
-- TODO-ACCESS:
-- check userId CanFillUserCorpus userCorpusId
-- check masterUserId CanFillMasterCorpus masterCorpusId
+-- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
+-- TODO-EVENTS: InsertedNodes
-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ConstrainedClassMethods #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
+ ( FlowCmdM
+ , flowCorpusFile
+ , flowCorpus
+ , flowCorpusSearchInDatabase
+ , getOrMkRoot
+ , getOrMkRootWithCorpus
+ , flowAnnuaire
+ )
where
-
---import Gargantext.Database.Metrics.Count (getNgramsElementsWithParentNodeId)
---import Gargantext.Database.Metrics.TFICF (getTficf)
---import Gargantext.Database.Node.Contact (HyperdataContact(..))
---import Gargantext.Database.Schema.NodeNgram (NodeNgramPoly(..), insertNodeNgrams)
---import Gargantext.Database.Schema.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
---import Gargantext.Database.Schema.User (insertUsers, simpleUser, gargantuaUser)
-import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
---import Gargantext.Text.Metrics.TFICF (Tficf(..))
---import Debug.Trace (trace)
-import Control.Lens ((^.), view, Lens', _Just)
-import Control.Monad (mapM_)
+import Prelude (String)
+import Data.Either
+import Debug.Trace (trace)
+import Control.Lens ((^.), view, _Just)
import Control.Monad.IO.Class (liftIO)
import Data.List (concat)
-import Data.Map (Map, lookup, toList)
+import Data.Map (Map, lookup)
import Data.Maybe (Maybe(..), catMaybes)
import Data.Monoid
import Data.Text (Text, splitOn, intercalate)
-import GHC.Show (Show)
-import Gargantext.API.Ngrams (HasRepoVar)
-import Gargantext.API.Ngrams (NgramsElement, putListNgrams, RepoCmdM)
import Gargantext.Core (Lang(..))
import Gargantext.Core.Types (NodePoly(..), Terms(..))
import Gargantext.Core.Types.Individu (Username)
+import Gargantext.Core.Flow
import Gargantext.Core.Types.Main
-import Gargantext.Database.TextSearch (searchInDatabase)
import Gargantext.Database.Config (userMaster, corpusMasterName)
-import Gargantext.Database.Flow.Utils (insertToNodeNgrams)
-import Gargantext.Database.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
+import Gargantext.Database.Flow.Utils (insertDocNgrams)
+import Gargantext.Database.Flow.List
+import Gargantext.Database.Flow.Types
import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..))
+import Gargantext.Database.Node.Document.Insert -- (insertDocuments, ReturnId(..), addUniqIdsDoc, addUniqIdsContact, ToDbData(..))
import Gargantext.Database.Root (getRoot)
import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams, NgramsType(..), text2ngrams, ngramsTypeId)
-import Gargantext.Database.Schema.Node -- (mkRoot, mkCorpus, getOrMkList, mkGraph, mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError, NodeError(..), nodeError)
+import Gargantext.Database.Schema.Node -- (mkRoot, mkCorpus, getOrMkList, mkGraph, {-mkPhylo,-} mkDashboard, mkAnnuaire, getCorporaWithParentId, HasNodeError, NodeError(..), nodeError)
import Gargantext.Database.Schema.User (getUser, UserLight(..))
+import Gargantext.Database.TextSearch (searchInDatabase)
import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
-import Gargantext.Database.Utils (Cmd, CmdM)
+import Gargantext.Database.Utils (Cmd)
import Gargantext.Ext.IMT (toSchoolName)
+import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
import Gargantext.Prelude
+import Gargantext.Text.Terms.Eleve (buildTries, toToken)
import Gargantext.Text.List (buildNgramsLists,StopSize(..))
-import Gargantext.Text.Parsers (parseDocs, FileFormat)
-import Gargantext.Text.Terms (TermType(..), tt_lang)
-import Gargantext.Text.Terms (extractTerms)
+import Gargantext.Text.Corpus.Parsers (parseFile, FileFormat)
+import qualified Gargantext.Text.Corpus.API.Isidore as Isidore
+import Gargantext.Text.Terms (TermType(..), tt_lang, extractTerms, uniText)
import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
-import qualified Gargantext.Text.Parsers.GrandDebat as GD
-import Servant (ServantErr)
+import Gargantext.Prelude.Utils hiding (sha)
import System.FilePath (FilePath)
-import qualified Data.Map as DM
+import qualified Data.List as List
+import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Gargantext.Database.Node.Document.Add as Doc (add)
+import qualified Gargantext.Text.Corpus.Parsers.GrandDebat as GD
-type FlowCmdM env err m =
- ( CmdM env err m
- , RepoCmdM env err m
- , HasNodeError err
- , HasRepoVar env
- )
+------------------------------------------------------------------------
-type FlowCorpus a = ( AddUniqId a
- , UniqId a
- , InsertDb a
- , ExtractNgramsT a
- )
+data ApiQuery = ApiIsidoreQuery Text | ApiIsidoreAuth Text
+-- | APIs
+-- TODO instances
+getDataApi :: Lang
+ -> Maybe Limit
+ -> ApiQuery
+ -> IO [HyperdataDocument]
+getDataApi lang limit (ApiIsidoreQuery q) = Isidore.get lang limit (Just q) Nothing
+getDataApi lang limit (ApiIsidoreAuth q) = Isidore.get lang limit Nothing (Just q)
+
+
+-- UNUSED
+_flowCorpusApi :: ( FlowCmdM env err m)
+ => Username -> Either CorpusName [CorpusId]
+ -> TermType Lang
+ -> Maybe Limit
+ -> ApiQuery
+ -> m CorpusId
+_flowCorpusApi u n tt l q = do
+ docs <- liftIO $ splitEvery 500 <$> getDataApi (_tt_lang tt) l q
+ flowCorpus u n tt docs
------------------------------------------------------------------------
-flowAnnuaire :: FlowCmdM env ServantErr m
- => Username -> CorpusName -> (TermType Lang) -> FilePath -> m AnnuaireId
+flowAnnuaire :: FlowCmdM env err m
+ => Username
+ -> Either CorpusName [CorpusId]
+ -> (TermType Lang)
+ -> FilePath
+ -> m AnnuaireId
flowAnnuaire u n l filePath = do
docs <- liftIO $ (( splitEvery 500 <$> deserialiseImtUsersFromFile filePath) :: IO [[HyperdataContact]])
flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
-
-flowCorpusDebat :: FlowCmdM env ServantErr m
- => Username -> CorpusName
- -> Limit -> FilePath
- -> m CorpusId
-flowCorpusDebat u n l fp = do
+-- UNUSED
+_flowCorpusDebat :: FlowCmdM env err m
+ => Username -> Either CorpusName [CorpusId]
+ -> Limit -> FilePath
+ -> m CorpusId
+_flowCorpusDebat u n l fp = do
docs <- liftIO ( splitEvery 500
<$> take l
- <$> GD.readFile fp
+ <$> readFile' fp
:: IO [[GD.GrandDebatReference ]]
)
flowCorpus u n (Multi FR) (map (map toHyperdataDocument) docs)
-
-flowCorpusFile :: FlowCmdM env ServantErr m
- => Username -> CorpusName
- -> Limit -- ^ Limit the number of docs (for dev purpose)
+flowCorpusFile :: FlowCmdM env err m
+ => Username -> Either CorpusName [CorpusId]
+ -> Limit -- Limit the number of docs (for dev purpose)
-> TermType Lang -> FileFormat -> FilePath
-> m CorpusId
flowCorpusFile u n l la ff fp = do
docs <- liftIO ( splitEvery 500
<$> take l
- <$> parseDocs ff fp
+ <$> parseFile ff fp
)
flowCorpus u n la (map (map toHyperdataDocument) docs)
-- TODO query with complex query
-flowCorpusSearchInDatabase :: FlowCmdM env ServantErr m
- => Username -> Lang -> Text -> m CorpusId
+flowCorpusSearchInDatabase :: FlowCmdM env err m
+ => Username
+ -> Lang
+ -> Text
+ -> m CorpusId
flowCorpusSearchInDatabase u la q = do
- (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus userMaster "" (Nothing :: Maybe HyperdataCorpus)
+ (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus
+ userMaster
+ (Left "")
+ (Nothing :: Maybe HyperdataCorpus)
+ ids <- map fst <$> searchInDatabase cId (stemIt q)
+ flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
+
+
+-- UNUSED
+_flowCorpusSearchInDatabaseApi :: FlowCmdM env err m
+ => Username
+ -> Lang
+ -> Text
+ -> m CorpusId
+_flowCorpusSearchInDatabaseApi u la q = do
+ (_masterUserId, _masterRootId, cId) <- getOrMkRootWithCorpus
+ userMaster
+ (Left "")
+ (Nothing :: Maybe HyperdataCorpus)
ids <- map fst <$> searchInDatabase cId (stemIt q)
- flowCorpusUser la u q (Nothing :: Maybe HyperdataCorpus) ids
+ flowCorpusUser la u (Left q) (Nothing :: Maybe HyperdataCorpus) ids
------------------------------------------------------------------------
+-- | TODO improve the needed type to create/update a corpus
+{- UNUSED
+data UserInfo = Username Text
+ | UserId NodeId
+data CorpusInfo = CorpusName Lang Text
+ | CorpusId Lang NodeId
+-}
--- TODO-ACCESS: check uId CanInsertDoc pId && checkDocType nodeType
--- TODO-EVENTS: InsertedNodes
-
-
-flow :: (FlowCmdM env ServantErr m, FlowCorpus a, MkCorpus c)
- => Maybe c -> Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
+flow :: (FlowCmdM env err m, FlowCorpus a, MkCorpus c)
+ => Maybe c
+ -> Username
+ -> Either CorpusName [CorpusId]
+ -> TermType Lang
+ -> [[a]]
+ -> m CorpusId
flow c u cn la docs = do
ids <- mapM (insertMasterDocs c la ) docs
flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
-flowCorpus :: (FlowCmdM env ServantErr m, FlowCorpus a)
- => Username -> CorpusName -> TermType Lang -> [[a]] -> m CorpusId
+flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
+ => Username
+ -> Either CorpusName [CorpusId]
+ -> TermType Lang
+ -> [[a]]
+ -> m CorpusId
flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
-
-flowCorpusUser :: (FlowCmdM env ServantErr m, MkCorpus c)
- => Lang -> Username -> CorpusName -> Maybe c -> [NodeId] -> m CorpusId
+------------------------------------------------------------------------
+flowCorpusUser :: (FlowCmdM env err m, MkCorpus c)
+ => Lang
+ -> Username
+ -> Either CorpusName [CorpusId]
+ -> Maybe c
+ -> [NodeId]
+ -> m CorpusId
flowCorpusUser l userName corpusName ctype ids = do
-- User Flow
(userId, _rootId, userCorpusId) <- getOrMkRootWithCorpus userName corpusName ctype
+ listId <- getOrMkList userCorpusId userId
+ _cooc <- mkNode NodeListCooc listId userId
-- TODO: check if present already, ignore
_ <- Doc.add userCorpusId ids
+ _tId <- mkNode NodeTexts userCorpusId userId
+ -- printDebug "Node Text Id" tId
+
-- User List Flow
--{-
- (_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster "" ctype
- ngs <- buildNgramsLists l 2 3 (StopSize 3) userCorpusId masterCorpusId
- userListId <- flowList userId userCorpusId ngs
- printDebug "userListId" userListId
+ (_masterUserId, _masterRootId, masterCorpusId) <- getOrMkRootWithCorpus userMaster (Left "") ctype
+ ngs <- buildNgramsLists l 2 3 (StopSize 3) userCorpusId masterCorpusId
+ _userListId <- flowList listId ngs
+ --mastListId <- getOrMkList masterCorpusId masterUserId
+ -- _ <- insertOccsUpdates userCorpusId mastListId
+ -- printDebug "userListId" userListId
-- User Graph Flow
+ _ <- mkDashboard userCorpusId userId
_ <- mkGraph userCorpusId userId
+ --_ <- mkPhylo userCorpusId userId
--}
- -- User Dashboard Flow
- _ <- mkDashboard userCorpusId userId
-- Annuaire Flow
-- _ <- mkAnnuaire rootUserId userId
pure userCorpusId
-insertMasterDocs :: ( FlowCmdM env ServantErr m
+insertMasterDocs :: ( FlowCmdM env err m
, FlowCorpus a
, MkCorpus c
)
- => Maybe c -> TermType Lang -> [a] -> m [DocId]
+ => Maybe c
+ -> TermType Lang
+ -> [a]
+ -> m [DocId]
insertMasterDocs c lang hs = do
- (masterUserId, _, masterCorpusId) <- getOrMkRootWithCorpus userMaster corpusMasterName c
+ (masterUserId, _, masterCorpusId) <- getOrMkRootWithCorpus userMaster (Left corpusMasterName) c
-- TODO Type NodeDocumentUnicised
let hs' = map addUniqId hs
ids <- insertDb masterUserId masterCorpusId hs'
- let documentsWithId = mergeData (toInserted ids) (DM.fromList $ map viewUniqId' hs')
-
- docsWithNgrams <- documentIdWithNgrams (extractNgramsT lang) documentsWithId
+ let documentsWithId = mergeData (toInserted ids) (Map.fromList $ map viewUniqId' hs')
- let maps = mapNodeIdNgrams docsWithNgrams
+ let
+ fixLang (Unsupervised l n s m) = Unsupervised l n s m'
+ where
+ m' = case m of
+ Nothing -> trace ("buildTries here" :: String)
+ $ Just
+ $ buildTries n ( fmap toToken $ uniText
+ $ Text.intercalate " . "
+ $ List.concat
+ $ map hasText documentsWithId
+ )
+ just_m -> just_m
+ fixLang l = l
+
+ lang' = fixLang lang
+ -- maps :: IO Map Ngrams (Map NgramsType (Map NodeId Int))
+ maps <- mapNodeIdNgrams <$> documentIdWithNgrams (extractNgramsT lang') documentsWithId
+ terms2id <- insertNgrams $ Map.keys maps
+ let indexedNgrams = Map.mapKeys (indexNgrams terms2id) maps
+
+ lId <- getOrMkList masterCorpusId masterUserId
+ _cooc <- mkNode NodeListCooc lId masterUserId
+ _ <- insertDocNgrams lId indexedNgrams
- terms2id <- insertNgrams $ DM.keys maps
- let indexedNgrams = DM.mapKeys (indexNgrams terms2id) maps
- _ <- insertToNodeNgrams indexedNgrams
pure $ map reId ids
-
type CorpusName = Text
-getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
- => Username -> CorpusName -> Maybe a
- -> Cmd err (UserId, RootId, CorpusId)
-getOrMkRootWithCorpus username cName c = do
+
+getOrMkRoot :: (HasNodeError err)
+ => Username
+ -> Cmd err (UserId, RootId)
+getOrMkRoot username = do
maybeUserId <- getUser username
userId <- case maybeUserId of
Nothing -> nodeError NoUserFound
False -> pure rootId'
rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
+ pure (userId, rootId)
+
+getOrMkRootWithCorpus :: (HasNodeError err, MkCorpus a)
+ => Username
+ -> Either CorpusName [CorpusId]
+ -> Maybe a
+ -> Cmd err (UserId, RootId, CorpusId)
+getOrMkRootWithCorpus username cName c = do
+ (userId, rootId) <- getOrMkRoot username
corpusId'' <- if username == userMaster
then do
ns <- getCorporaWithParentId rootId
pure $ map _node_id ns
else
- pure []
-
+ pure $ fromRight [] cName
+
corpusId' <- if corpusId'' /= []
then pure corpusId''
- else mk (Just cName) c rootId userId
+ else mk (Just $ fromLeft "Default" cName) c rootId userId
corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
------------------------------------------------------------------------
-
-
-class UniqId a
- where
- uniqId :: Lens' a (Maybe HashId)
-
-
-instance UniqId HyperdataDocument
- where
- uniqId = hyperdataDocument_uniqId
-
-instance UniqId HyperdataContact
- where
- uniqId = hc_uniqId
-
-viewUniqId' :: UniqId a => a -> (HashId, a)
+viewUniqId' :: UniqId a
+ => a
+ -> (HashId, a)
viewUniqId' d = maybe err (\h -> (h,d)) (view uniqId d)
where
err = panic "[ERROR] Database.Flow.toInsert"
-toInserted :: [ReturnId] -> Map HashId ReturnId
-toInserted = DM.fromList . map (\r -> (reUniqId r, r) )
- . filter (\r -> reInserted r == True)
-
-data DocumentWithId a = DocumentWithId
- { documentId :: !NodeId
- , documentData :: !a
- } deriving (Show)
+toInserted :: [ReturnId]
+ -> Map HashId ReturnId
+toInserted =
+ Map.fromList . map (\r -> (reUniqId r, r) )
+ . filter (\r -> reInserted r == True)
mergeData :: Map HashId ReturnId
-> Map HashId a
-> [DocumentWithId a]
-mergeData rs = catMaybes . map toDocumentWithId . DM.toList
+mergeData rs = catMaybes . map toDocumentWithId . Map.toList
where
- toDocumentWithId (hash,hpd) =
- DocumentWithId <$> fmap reId (lookup hash rs)
+ toDocumentWithId (sha,hpd) =
+ DocumentWithId <$> fmap reId (lookup sha rs)
<*> Just hpd
------------------------------------------------------------------------
-data DocumentIdWithNgrams a = DocumentIdWithNgrams
- { documentWithId :: !(DocumentWithId a)
- , document_ngrams :: !(Map Ngrams (Map NgramsType Int))
- } deriving (Show)
--- TODO extractNgrams according to Type of Data
-
-class ExtractNgramsT h
+instance HasText HyperdataContact
where
- extractNgramsT :: TermType Lang -> h -> Cmd err (Map Ngrams (Map NgramsType Int))
-
+ hasText = undefined
instance ExtractNgramsT HyperdataContact
where
$ maybe ["Nothing"] (\a -> [a])
$ view (hc_who . _Just . cw_lastName) hc'
- pure $ DM.fromList $ [(a', DM.singleton Authors 1) | a' <- authors ]
-
-
+ pure $ Map.fromList $ [(a', Map.singleton Authors 1) | a' <- authors ]
-
-instance ExtractNgramsT HyperdataDocument
+instance HasText HyperdataDocument
where
- extractNgramsT = extractNgramsT'
+ hasText h = catMaybes [ _hyperdataDocument_title h
+ , _hyperdataDocument_abstract h
+ ]
-extractNgramsT' :: TermType Lang -> HyperdataDocument
- -> Cmd err (Map Ngrams (Map NgramsType Int))
-extractNgramsT' lang hd = filterNgramsT 255 <$> extractNgramsT'' lang hd
+instance ExtractNgramsT HyperdataDocument
where
- extractNgramsT'' :: TermType Lang -> HyperdataDocument
+ extractNgramsT :: TermType Lang
+ -> HyperdataDocument
-> Cmd err (Map Ngrams (Map NgramsType Int))
- extractNgramsT'' lang' doc = do
- let source = text2ngrams
- $ maybe "Nothing" identity
- $ _hyperdataDocument_source doc
-
- institutes = map text2ngrams
- $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
- $ _hyperdataDocument_institutes doc
-
- authors = map text2ngrams
- $ maybe ["Nothing"] (splitOn ", ")
- $ _hyperdataDocument_authors doc
-
- leText = catMaybes [ _hyperdataDocument_title doc
- , _hyperdataDocument_abstract doc
- ]
-
- terms' <- map text2ngrams
- <$> map (intercalate " " . _terms_label)
- <$> concat
- <$> liftIO (extractTerms lang' leText)
-
- pure $ DM.fromList $ [(source, DM.singleton Sources 1)]
- <> [(i', DM.singleton Institutes 1) | i' <- institutes ]
- <> [(a', DM.singleton Authors 1) | a' <- authors ]
- <> [(t', DM.singleton NgramsTerms 1) | t' <- terms' ]
-
+ extractNgramsT lang hd = filterNgramsT 255 <$> extractNgramsT' lang hd
+ where
+ extractNgramsT' :: TermType Lang
+ -> HyperdataDocument
+ -> Cmd err (Map Ngrams (Map NgramsType Int))
+ extractNgramsT' lang' doc = do
+ let source = text2ngrams
+ $ maybe "Nothing" identity
+ $ _hyperdataDocument_source doc
+
+ institutes = map text2ngrams
+ $ maybe ["Nothing"] (map toSchoolName . (splitOn ", "))
+ $ _hyperdataDocument_institutes doc
+
+ authors = map text2ngrams
+ $ maybe ["Nothing"] (splitOn ", ")
+ $ _hyperdataDocument_authors doc
+
+ terms' <- map text2ngrams
+ <$> map (intercalate " " . _terms_label)
+ <$> concat
+ <$> liftIO (extractTerms lang' $ hasText doc)
+
+ pure $ Map.fromList $ [(source, Map.singleton Sources 1)]
+ <> [(i', Map.singleton Institutes 1) | i' <- institutes ]
+ <> [(a', Map.singleton Authors 1) | a' <- authors ]
+ <> [(t', Map.singleton NgramsTerms 1) | t' <- terms' ]
filterNgramsT :: Int -> Map Ngrams (Map NgramsType Int)
-> Map Ngrams (Map NgramsType Int)
-filterNgramsT s ms = DM.fromList $ map (\a -> filter' s a) $ DM.toList ms
+filterNgramsT s ms = Map.fromList $ map (\a -> filter' s a) $ Map.toList ms
where
filter' s' (ng@(Ngrams t n),y) = case (Text.length t) < s' of
True -> (ng,y)
documentIdWithNgrams f = mapM toDocumentIdWithNgrams
where
toDocumentIdWithNgrams d = do
- e <- f $ documentData d
- pure $ DocumentIdWithNgrams d e
-
-
-
--- FLOW LIST
--- | TODO check optimization
-mapNodeIdNgrams :: [DocumentIdWithNgrams a]
- -> Map Ngrams (Map NgramsType (Map NodeId Int))
-mapNodeIdNgrams = DM.unionsWith (DM.unionWith (DM.unionWith (+))) . fmap f
- where
- f :: DocumentIdWithNgrams a
- -> Map Ngrams (Map NgramsType (Map NodeId Int))
- f d = fmap (fmap (DM.singleton nId)) $ document_ngrams d
- where
- nId = documentId $ documentWithId d
-
-------------------------------------------------------------------------
-listInsert :: FlowCmdM env err m
- => ListId -> Map NgramsType [NgramsElement]
- -> m ()
-listInsert lId ngs = mapM_ (\(typeList, ngElmts)
- -> putListNgrams lId typeList ngElmts
- ) $ toList ngs
-
-flowList :: FlowCmdM env err m => UserId -> CorpusId
- -> Map NgramsType [NgramsElement]
- -> m ListId
-flowList uId cId ngs = do
- lId <- getOrMkList cId uId
- printDebug "listId flowList" lId
- listInsert lId ngs
- pure lId
+ e <- f $ documentData d
+ pure $ DocumentIdWithNgrams d e