Skip to content

haskell-gargantext
haskell-gargantext
Commit 54a4da56 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[NodeStory] NodeStory Integration, compilation with warning ok (WIP)

parent ee823c5a
Hide whitespace changes
Inline Side-by-side
Showing with 231 additions and 578 deletions
src/Gargantext/API.hs
View file @ 54a4da56
......@@ -28,36 +28,34 @@ Pouillard (who mainly made it).
{-# LANGUAGE ScopedTypeVariables #-}
---------------------------------------------------------------------
module Gargantext.API
where
---------------------------------------------------------------------
import Control.Exception (finally)
import Control.Lens
import Control.Monad.Reader (runReaderT)
import Data.List (lookup)
import Data.Text.Encoding (encodeUtf8)
import Data.Text.IO (putStrLn)
import Data.Validity
import GHC.Base (Applicative)
import GHC.Generics (Generic)
import Network.HTTP.Types hiding (Query)
import Network.Wai
import Network.Wai.Handler.Warp hiding (defaultSettings)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.RequestLogger
import Servant
import System.IO (FilePath)
import Data.Text.IO (putStrLn)
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.Settings (newEnv)
import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
import Gargantext.API.Ngrams (saveRepo)
import Gargantext.API.Ngrams.Types (HasRepoSaver(..))
import Gargantext.API.Prelude
import Gargantext.API.Routes
import Gargantext.API.Server (server)
import Gargantext.Core.NodeStory
import Gargantext.Prelude hiding (putStrLn)
import Network.HTTP.Types hiding (Query)
import Network.Wai
import Network.Wai.Handler.Warp hiding (defaultSettings)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.RequestLogger
import Servant
import System.IO (FilePath)
data Mode = Dev | Mock | Prod
......@@ -79,7 +77,7 @@ portRouteInfo port = do
putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
-- TODO clean this Monad condition (more generic) ?
stopGargantext :: HasRepoSaver env => env -> IO ()
stopGargantext :: HasNodeStorySaver env => env -> IO ()
stopGargantext env = do
putStrLn "----- Stopping gargantext -----"
runReaderT saveRepo env
......@@ -226,4 +224,4 @@ type family GenericTypeName t (r :: *) :: Symbol where
GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
-}
\ No newline at end of file
-}
src/Gargantext/API/Admin/EnvTypes.hs
View file @ 54a4da56
......@@ -16,7 +16,6 @@ import qualified Servant.Job.Core
import Gargantext.API.Admin.Types
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams.Types (HasRepoVar(..), HasRepoSaver(..), HasRepo(..), RepoEnv(..))
import Gargantext.Database.Prelude (HasConnectionPool(..), HasConfig(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..))
......@@ -26,7 +25,6 @@ data Env = Env
{ _env_settings :: !Settings
, _env_logger :: !LoggerSet
, _env_pool :: !(Pool Connection)
, _env_repo :: !RepoEnv
, _env_nodeStory :: !NodeStoryEnv
, _env_manager :: !Manager
, _env_self_url :: !BaseUrl
......@@ -43,6 +41,7 @@ instance HasConfig Env where
instance HasConnectionPool Env where
connPool = env_pool
{- To be removed
instance HasRepoVar Env where
repoVar = repoEnv . repoVar
......@@ -51,6 +50,13 @@ instance HasRepoSaver Env where
instance HasRepo Env where
repoEnv = env_repo
-}
-- TODONS
instance HasNodeStorySaver Env
instance HasNodeStoryEnv Env
instance HasNodeStoryVar Env
instance HasSettings Env where
settings = env_settings
......@@ -71,7 +77,7 @@ makeLenses ''MockEnv
data DevEnv = DevEnv
{ _dev_env_pool :: !(Pool Connection)
, _dev_env_repo :: !RepoEnv
, _dev_env_nodeStory :: !NodeStoryEnv
, _dev_env_settings :: !Settings
, _dev_env_config :: !GargConfig
}
......@@ -84,6 +90,10 @@ instance HasConfig DevEnv where
instance HasConnectionPool DevEnv where
connPool = dev_env_pool
-- TODONS
instance HasNodeStorySaver DevEnv
{-
instance HasRepoVar DevEnv where
repoVar = repoEnv . repoVar
......@@ -92,6 +102,7 @@ instance HasRepoSaver DevEnv where
instance HasRepo DevEnv where
repoEnv = dev_env_repo
-}
instance HasSettings DevEnv where
settings = dev_env_settings
src/Gargantext/API/Admin/Settings.hs
View file @ 54a4da56
......@@ -29,7 +29,6 @@ import Data.Pool (Pool, createPool)
import Database.PostgreSQL.Simple (Connection, connect, close, ConnectInfo)
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Types
import Gargantext.API.Ngrams.Types (NgramsRepo, HasRepo(..), RepoEnv(..), r_version, initRepo, renv_var, renv_lock)
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude (databaseParameters, HasConfig(..))
import Gargantext.Prelude
......@@ -110,6 +109,7 @@ repoSaverAction repoDir a = do
{-
-- The use of mkDebounce makes sure that repoSaverAction is not called too often.
-- If repoSaverAction start taking more time than the debounceFreq then it should
-- be increased.
......@@ -158,6 +158,7 @@ readRepoEnv repoDir = do
-- TODO save in DB here
saver <- mkRepoSaver repoDir mvar
pure $ RepoEnv { _renv_var = mvar, _renv_saver = saver, _renv_lock = lock }
-}
devJwkFile :: FilePath
devJwkFile = "dev.jwk"
......@@ -173,7 +174,7 @@ newEnv port file = do
self_url_env <- parseBaseUrl $ "http://0.0.0.0:" <> show port
dbParam <- databaseParameters file
pool <- newPool dbParam
repo <- readRepoEnv (_gc_repofilepath config_env)
-- repo <- readRepoEnv (_gc_repofilepath config_env)
nodeStory_env <- readNodeStoryEnv (_gc_repofilepath config_env)
scrapers_env <- newJobEnv defaultSettings manager_env
logger <- newStderrLoggerSet defaultBufSize
......@@ -182,7 +183,7 @@ newEnv port file = do
{ _env_settings = settings'
, _env_logger = logger
, _env_pool = pool
, _env_repo = repo
-- , _env_repo = repo
, _env_nodeStory = nodeStory_env
, _env_manager = manager_env
, _env_scrapers = scrapers_env
......@@ -193,9 +194,10 @@ newEnv port file = do
newPool :: ConnectInfo -> IO (Pool Connection)
newPool param = createPool (connect param) close 1 (60*60) 8
{-
cleanEnv :: (HasConfig env, HasRepo env) => env -> IO ()
cleanEnv env = do
r <- takeMVar (env ^. repoEnv . renv_var)
repoSaverAction (env ^. hasConfig . gc_repofilepath) r
unlockFile (env ^. repoEnv . renv_lock)
-}
src/Gargantext/API/Dev.hs
View file @ 54a4da56
......@@ -15,15 +15,15 @@ module Gargantext.API.Dev where
import Control.Exception (finally)
import Control.Monad (fail)
import Control.Monad.Reader (runReaderT)
import Servant
import Gargantext.API.Prelude
import Gargantext.API.Admin.Settings
import Gargantext.API.Admin.EnvTypes
import Gargantext.API.Admin.Settings
import Gargantext.API.Ngrams (saveRepo)
import Gargantext.API.Prelude
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig(..), readConfig)
import Servant
import System.IO (FilePath)
type IniPath = FilePath
......@@ -31,24 +31,25 @@ type IniPath = FilePath
withDevEnv :: IniPath -> (DevEnv -> IO a) -> IO a
withDevEnv iniPath k = do
env <- newDevEnv
k env `finally` cleanEnv env
k env
-- k env `finally` cleanEnv env
where
newDevEnv = do
cfg <- readConfig iniPath
dbParam <- databaseParameters iniPath
nodeStory_env <- readNodeStoryEnv (_gc_repofilepath cfg)
pool <- newPool dbParam
repo <- readRepoEnv (_gc_repofilepath cfg)
setts <- devSettings devJwkFile
pure $ DevEnv
{ _dev_env_pool = pool
, _dev_env_repo = repo
, _dev_env_nodeStory = nodeStory_env
, _dev_env_settings = setts
, _dev_env_config = cfg
}
-- | Run Cmd Sugar for the Repl (GHCI)
runCmdRepl :: Show err => Cmd'' DevEnv err a -> IO a
runCmdRepl :: (Show err, HasNodeStorySaver DevEnv) => Cmd'' DevEnv err a -> IO a
runCmdRepl f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
runCmdReplServantErr :: Cmd'' DevEnv ServerError a -> IO a
......@@ -58,17 +59,17 @@ runCmdReplServantErr = runCmdRepl
-- the command.
-- This function is constrained to the DevEnv rather than
-- using HasConnectionPool and HasRepoVar.
runCmdDev :: Show err => DevEnv -> Cmd'' DevEnv err a -> IO a
runCmdDev :: (Show err, HasNodeStorySaver DevEnv) => DevEnv -> Cmd'' DevEnv err a -> IO a
runCmdDev env f =
(either (fail . show) pure =<< runCmd env f)
`finally`
runReaderT saveRepo env
runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
runCmdDevNoErr :: (HasNodeStorySaver DevEnv) => DevEnv -> Cmd' DevEnv () a -> IO a
runCmdDevNoErr = runCmdDev
runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServerError a -> IO a
runCmdDevServantErr :: (HasNodeStorySaver DevEnv) => DevEnv -> Cmd' DevEnv ServerError a -> IO a
runCmdDevServantErr = runCmdDev
runCmdReplEasy :: Cmd'' DevEnv GargError a -> IO a
runCmdReplEasy :: (HasNodeStorySaver DevEnv) => Cmd'' DevEnv GargError a -> IO a
runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
src/Gargantext/API/Metrics.hs
View file @ 54a4da56
......@@ -30,10 +30,10 @@ import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeL
import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
import Gargantext.Core.Viz.Chart
import Gargantext.Core.Viz.Types
import Gargantext.Database.Action.Flow
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
......
src/Gargantext/API/Ngrams.hs
View file @ 54a4da56
......@@ -63,10 +63,6 @@ module Gargantext.API.Ngrams
, TabType(..)
, HasRepoVar(..)
, HasRepoSaver(..)
, HasRepo(..)
, RepoCmdM
, QueryParamR
, TODO
......@@ -183,34 +179,21 @@ mkChildrenGroups addOrRem nt patches =
------------------------------------------------------------------------
saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
saveRepo :: ( MonadReader env m, MonadBase IO m, HasNodeStorySaver env )
=> m ()
saveRepo = liftBase =<< view repoSaver
saveRepo' :: ( MonadReader env m, MonadBase IO m, HasNodeStorySaver env )
=> m ()
saveRepo' = liftBase =<< view hasNodeStorySaver
saveRepo = liftBase =<< view hasNodeStorySaver
listTypeConflictResolution :: ListType -> ListType -> ListType
listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
ngramsStatePatchConflictResolution
:: TableNgrams.NgramsType
-> NodeId
-> NgramsTerm
-> ConflictResolutionNgramsPatch
ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
= (ours, (const ours, ours), (False, False))
-- (False, False) mean here that Mod has always priority.
-- (True, False) <- would mean priority to the left (same as ours).
-- undefined {- TODO think this through -}, listTypeConflictResolution)
ngramsStatePatchConflictResolution'
ngramsStatePatchConflictResolution
:: TableNgrams.NgramsType
-> NgramsTerm
-> ConflictResolutionNgramsPatch
ngramsStatePatchConflictResolution' _ngramsType _ngramsTerm
ngramsStatePatchConflictResolution _ngramsType _ngramsTerm
= (ours, (const ours, ours), (False, False))
-- (False, False) mean here that Mod has always priority.
-- (True, False) <- would mean priority to the left (same as ours).
......@@ -260,26 +243,12 @@ addListNgrams listId ngramsType nes = do
-- && should use patch
-- UNSAFE
setListNgrams :: RepoCmdM env err m
setListNgrams :: HasNodeStory env err m
=> NodeId
-> TableNgrams.NgramsType
-> Map NgramsTerm NgramsRepoElement
-> m ()
setListNgrams listId ngramsType ns = do
var <- view repoVar
liftBase $ modifyMVar_ var $
pure . ( r_state
. at ngramsType
%~ Just . (at listId .~ Just ns) . something
)
printDebug "List modified" NodeList
saveRepo
setListNgrams' :: HasNodeStory env err m
=> NodeId
-> TableNgrams.NgramsType
-> Map NgramsTerm NgramsRepoElement
-> m ()
setListNgrams' listId ngramsType ns = do
getter <- view hasNodeStory
var <- liftBase $ (getter ^. nse_getter) listId
liftBase $ modifyMVar_ var $
......@@ -289,32 +258,18 @@ setListNgrams' listId ngramsType ns = do
. at ngramsType
.~ Just ns
)
saveRepo'
saveRepo
currentVersion :: RepoCmdM env err m
=> m Version
currentVersion = do
var <- view repoVar
r <- liftBase $ readMVar var
pure $ r ^. r_version
currentVersion' :: HasNodeStory env err m
currentVersion :: HasNodeStory env err m
=> ListId -> m Version
currentVersion' listId = do
currentVersion listId = do
nls <- getRepo' [listId]
pure $ nls ^. unNodeStory . at listId . _Just . a_version
newNgramsFromNgramsStatePatch :: NgramsStatePatch -> [Ngrams]
newNgramsFromNgramsStatePatch :: NgramsStatePatch' -> [Ngrams]
newNgramsFromNgramsStatePatch p =
[ text2ngrams (unNgramsTerm n)
| (n,np) <- p ^.. _PatchMap . each . _PatchMap . each . _NgramsTablePatch . _PatchMap . ifolded . withIndex
, _ <- np ^.. patch_new . _Just
]
newNgramsFromNgramsStatePatch' :: NgramsStatePatch' -> [Ngrams]
newNgramsFromNgramsStatePatch' p =
[ text2ngrams (unNgramsTerm n)
| (n,np) <- p ^.. _PatchMap
-- . each . _PatchMap
......@@ -325,84 +280,38 @@ newNgramsFromNgramsStatePatch' p =
-- tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
commitStatePatch :: RepoCmdM env err m
=> Versioned NgramsStatePatch
-> m (Versioned NgramsStatePatch)
commitStatePatch (Versioned p_version p) = do
var <- view repoVar
vq' <- liftBase $ modifyMVar var $ \r -> do
let
q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
(p', q') = transformWith ngramsStatePatchConflictResolution p q
r' = r & r_version +~ 1
& r_state %~ act p'
& r_history %~ (p' :)
{-
-- Ideally we would like to check these properties. However:
-- * They should be checked only to debug the code. The client data
-- should be able to trigger these.
-- * What kind of error should they throw (we are in IO here)?
-- * Should we keep modifyMVar?
-- * Should we throw the validation in an Exception, catch it around
-- modifyMVar and throw it back as an Error?
assertValid $ transformable p q
assertValid $ applicable p' (r ^. r_state)
-}
pure (r', Versioned (r' ^. r_version) q')
saveRepo
-- Save new ngrams
_ <- insertNgrams (newNgramsFromNgramsStatePatch p)
pure vq'
commitStatePatch' :: HasNodeStory env err m
commitStatePatch :: HasNodeStory env err m
=> ListId
-> Versioned NgramsStatePatch'
-> m (Versioned NgramsStatePatch')
commitStatePatch' listId (Versioned p_version p) = do
commitStatePatch listId (Versioned p_version p) = do
var <- getRepoVar listId
vq' <- liftBase $ modifyMVar var $ \ns -> do
let
a = ns ^. unNodeStory . at listId . _Just
q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
(p', q') = transformWith ngramsStatePatchConflictResolution' p q
(p', q') = transformWith ngramsStatePatchConflictResolution p q
a' = a & a_version +~ 1
& a_state %~ act p'
& a_history %~ (p' :)
pure ( ns & unNodeStory . at listId .~ (Just a')
, Versioned (a' ^. a_version) q'
)
saveRepo'
saveRepo
-- Save new ngrams
_ <- insertNgrams (newNgramsFromNgramsStatePatch' p)
_ <- insertNgrams (newNgramsFromNgramsStatePatch p)
pure $ vq'
-- This is a special case of tableNgramsPut where the input patch is empty.
tableNgramsPull :: RepoCmdM env err m
tableNgramsPull :: HasNodeStory env err m
=> ListId
-> TableNgrams.NgramsType
-> Version
-> m (Versioned NgramsTablePatch)
tableNgramsPull listId ngramsType p_version = do
var <- view repoVar
r <- liftBase $ readMVar var
let
q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
q_table = q ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
pure (Versioned (r ^. r_version) q_table)
tableNgramsPull' :: HasNodeStory env err m
=> ListId
-> TableNgrams.NgramsType
-> Version
-> m (Versioned NgramsTablePatch)
tableNgramsPull' listId ngramsType p_version = do
var <- getRepoVar listId
r <- liftBase $ readMVar var
......@@ -419,7 +328,8 @@ tableNgramsPull' listId ngramsType p_version = do
-- Apply the given patch to the DB and returns the patch to be applied on the
-- client.
-- TODO-ACCESS check
tableNgramsPut :: ( FlowCmdM env err m
tableNgramsPut :: ( HasNodeStory env err m
, HasInvalidError err
, HasSettings env
)
=> TabType
......@@ -431,45 +341,21 @@ tableNgramsPut tabType listId (Versioned p_version p_table)
let ngramsType = ngramsTypeFromTabType tabType
tableNgramsPull listId ngramsType p_version
| otherwise = do
let ngramsType = ngramsTypeFromTabType tabType
(p0, p0_validity) = PM.singleton listId p_table
(p, p_validity) = PM.singleton ngramsType p0
assertValid p0_validity
assertValid p_validity
ret <- commitStatePatch (Versioned p_version p)
<&> v_data %~ (view (_PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just))
pure ret
tableNgramsPut' :: ( HasNodeStory env err m
, HasInvalidError err
, HasSettings env
)
=> TabType
-> ListId
-> Versioned NgramsTablePatch
-> m (Versioned NgramsTablePatch)
tableNgramsPut' tabType listId (Versioned p_version p_table)
| p_table == mempty = do
let ngramsType = ngramsTypeFromTabType tabType
tableNgramsPull' listId ngramsType p_version
| otherwise = do
let ngramsType = ngramsTypeFromTabType tabType
(p, p_validity) = PM.singleton ngramsType p_table
assertValid p_validity
ret <- commitStatePatch' listId (Versioned p_version p)
ret <- commitStatePatch listId (Versioned p_version p)
<&> v_data %~ (view (_PatchMap . at ngramsType . _Just))
pure ret
tableNgramsPostChartsAsync :: ( FlowCmdM env err m
tableNgramsPostChartsAsync :: ( HasNodeStory env err m
, FlowCmdM env err m
, HasNodeError err
, HasSettings env
)
......@@ -557,27 +443,18 @@ tableNgramsPostChartsAsync utn logStatus = do
}
-}
getNgramsTableMap :: RepoCmdM env err m
getNgramsTableMap :: HasNodeStory env err m
=> NodeId
-> TableNgrams.NgramsType
-> m (Versioned NgramsTableMap)
getNgramsTableMap nodeId ngramsType = do
v <- view repoVar
repo <- liftBase $ readMVar v
pure $ Versioned (repo ^. r_version)
(repo ^. r_state . at ngramsType . _Just . at nodeId . _Just)
getNgramsTableMap' :: HasNodeStory env err m
=> NodeId
-> TableNgrams.NgramsType
-> m (Versioned NgramsTableMap)
getNgramsTableMap' nodeId ngramsType = do
v <- getRepoVar nodeId
repo <- liftBase $ readMVar v
pure $ Versioned (repo ^. unNodeStory . at nodeId . _Just . a_version)
(repo ^. unNodeStory . at nodeId . _Just . a_state . at ngramsType . _Just)
dumpJsonTableMap :: RepoCmdM env err m
dumpJsonTableMap :: HasNodeStory env err m
=> Text
-> NodeId
-> TableNgrams.NgramsType
......@@ -586,16 +463,6 @@ dumpJsonTableMap fpath nodeId ngramsType = do
m <- getNgramsTableMap nodeId ngramsType
liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
pure ()
dumpJsonTableMap' :: HasNodeStory env err m
=> Text
-> NodeId
-> TableNgrams.NgramsType
-> m ()
dumpJsonTableMap' fpath nodeId ngramsType = do
m <- getNgramsTableMap' nodeId ngramsType
liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
pure ()
type MinSize = Int
......@@ -608,7 +475,7 @@ type MaxSize = Int
getTableNgrams :: forall env err m.
(RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
(HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeType -> NodeId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
......@@ -727,131 +594,11 @@ getTableNgrams _nType nId tabType listId limit_ offset
% "\n"
) t0 t3 t0 t1 t1 t2 t2 t3
pure $ toVersionedWithCount fltrCount tableMap3
getTableNgrams' :: forall env err m.
(HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeType -> NodeId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
-> Maybe MinSize -> Maybe MaxSize
-> Maybe OrderBy
-> (NgramsTerm -> Bool)
-> m (VersionedWithCount NgramsTable)
getTableNgrams' _nType nId tabType listId limit_ offset
listType minSize maxSize orderBy searchQuery = do
t0 <- getTime
-- lIds <- selectNodesWithUsername NodeList userMaster
let
ngramsType = ngramsTypeFromTabType tabType
offset' = maybe 0 identity offset
listType' = maybe (const True) (==) listType
minSize' = maybe (const True) (<=) minSize
maxSize' = maybe (const True) (>=) maxSize
selected_node n = minSize' s
&& maxSize' s
&& searchQuery (n ^. ne_ngrams)
&& listType' (n ^. ne_list)
where
s = n ^. ne_size
selected_inner roots n = maybe False (`Set.member` roots) (n ^. ne_root)
---------------------------------------
sortOnOrder Nothing = identity
sortOnOrder (Just TermAsc) = List.sortOn $ view ne_ngrams
sortOnOrder (Just TermDesc) = List.sortOn $ Down . view ne_ngrams
sortOnOrder (Just ScoreAsc) = List.sortOn $ view ne_occurrences
sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view ne_occurrences
---------------------------------------
filteredNodes :: Map NgramsTerm NgramsElement -> [NgramsElement]
filteredNodes tableMap = rootOf <$> list & filter selected_node
where
rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root")
(tableMap ^. at r)
)
(ne ^. ne_root)
list = tableMap ^.. each
---------------------------------------
selectAndPaginate :: Map NgramsTerm NgramsElement -> [NgramsElement]
selectAndPaginate tableMap = roots <> inners
where
list = tableMap ^.. each
rootOf ne = maybe ne (\r -> fromMaybe (panic "getTableNgrams: invalid root")
(tableMap ^. at r)
)
(ne ^. ne_root)
selected_nodes = list & take limit_
. drop offset'
. filter selected_node
. sortOnOrder orderBy
roots = rootOf <$> selected_nodes
rootsSet = Set.fromList (_ne_ngrams <$> roots)
inners = list & filter (selected_inner rootsSet)
---------------------------------------
setScores :: forall t. Each t t NgramsElement NgramsElement => Bool -> t -> m t
setScores False table = pure table
setScores True table = do
let ngrams_terms = table ^.. each . ne_ngrams
t1 <- getTime
occurrences <- getOccByNgramsOnlyFast' nId
listId
ngramsType
ngrams_terms
t2 <- getTime
liftBase $ hprint stderr
("getTableNgrams/setScores #ngrams=" % int % " time=" % hasTime % "\n")
(length ngrams_terms) t1 t2
{-
occurrences <- getOccByNgramsOnlySlow nType nId
(lIds <> [listId])
ngramsType
ngrams_terms
-}
let
setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
pure $ table & each %~ setOcc
---------------------------------------
-- lists <- catMaybes <$> listsWith userMaster
-- trace (show lists) $
-- getNgramsTableMap ({-lists <>-} listIds) ngramsType
let scoresNeeded = needsScores orderBy
tableMap1 <- getNgramsTableMap' listId ngramsType
t1 <- getTime
tableMap2 <- tableMap1 & v_data %%~ setScores scoresNeeded
. Map.mapWithKey ngramsElementFromRepo
fltr <- tableMap2 & v_data %%~ fmap NgramsTable . setScores (not scoresNeeded)
. filteredNodes
let fltrCount = length $ fltr ^. v_data . _NgramsTable
t2 <- getTime
tableMap3 <- tableMap2 & v_data %%~ fmap NgramsTable
. setScores (not scoresNeeded)
. selectAndPaginate
t3 <- getTime
liftBase $ hprint stderr
("getTableNgrams total=" % hasTime
% " map1=" % hasTime
% " map2=" % hasTime
% " map3=" % hasTime
% " sql=" % (if scoresNeeded then "map2" else "map3")
% "\n"
) t0 t3 t0 t1 t1 t2 t2 t3
pure $ toVersionedWithCount fltrCount tableMap3
scoresRecomputeTableNgrams :: forall env err m.
(RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
(HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeId -> TabType -> ListId -> m Int
scoresRecomputeTableNgrams nId tabType listId = do
tableMap <- getNgramsTableMap listId ngramsType
......@@ -873,29 +620,6 @@ scoresRecomputeTableNgrams nId tabType listId = do
setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
pure $ table & each %~ setOcc
scoresRecomputeTableNgrams' :: forall env err m.
(HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeId -> TabType -> ListId -> m Int
scoresRecomputeTableNgrams' nId tabType listId = do
tableMap <- getNgramsTableMap' listId ngramsType
_ <- tableMap & v_data %%~ setScores
. Map.mapWithKey ngramsElementFromRepo
pure $ 1
where
ngramsType = ngramsTypeFromTabType tabType
setScores :: forall t. Each t t NgramsElement NgramsElement => t -> m t
setScores table = do
let ngrams_terms = table ^.. each . ne_ngrams
occurrences <- getOccByNgramsOnlyFast' nId
listId
ngramsType
ngrams_terms
let
setOcc ne = ne & ne_occurrences .~ sumOf (at (ne ^. ne_ngrams) . _Just) occurrences
pure $ table & each %~ setOcc
......@@ -969,7 +693,7 @@ type TableNgramsAsyncApi = Summary "Table Ngrams Async API"
:> "update"
:> AsyncJobs JobLog '[JSON] UpdateTableNgramsCharts JobLog
getTableNgramsCorpus :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
getTableNgramsCorpus :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeId
-> TabType
-> ListId
......@@ -984,36 +708,15 @@ getTableNgramsCorpus nId tabType listId limit_ offset listType minSize maxSize o
getTableNgrams NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
where
searchQuery (NgramsTerm nt) = maybe (const True) isInfixOf mt nt
getTableNgramsCorpus' :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeId
-> TabType
-> ListId
-> Limit
-> Maybe Offset
-> Maybe ListType
-> Maybe MinSize -> Maybe MaxSize
-> Maybe OrderBy
-> Maybe Text -- full text search
-> m (VersionedWithCount NgramsTable)
getTableNgramsCorpus' nId tabType listId limit_ offset listType minSize maxSize orderBy mt =
getTableNgrams' NodeCorpus nId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
where
searchQuery (NgramsTerm nt) = maybe (const True) isInfixOf mt nt
getTableNgramsVersion :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeId
-> TabType
-> ListId
-> m Version
getTableNgramsVersion _nId _tabType _listId = currentVersion
getTableNgramsVersion' :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
getTableNgramsVersion :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> NodeId
-> TabType
-> ListId
-> m Version
getTableNgramsVersion' _nId _tabType listId = currentVersion' listId
getTableNgramsVersion _nId _tabType listId = currentVersion listId
......@@ -1024,7 +727,7 @@ getTableNgramsVersion' _nId _tabType listId = currentVersion' listId
-- | Text search is deactivated for now for ngrams by doc only
getTableNgramsDoc :: (RepoCmdM env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
getTableNgramsDoc :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> DocId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
......@@ -1038,21 +741,6 @@ getTableNgramsDoc dId tabType listId limit_ offset listType minSize maxSize orde
ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
let searchQuery (NgramsTerm nt) = flip S.member (S.fromList ngs) nt
getTableNgrams NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
getTableNgramsDoc' :: (HasNodeStory env err m, HasNodeError err, HasConnectionPool env, HasConfig env)
=> DocId -> TabType
-> ListId -> Limit -> Maybe Offset
-> Maybe ListType
-> Maybe MinSize -> Maybe MaxSize
-> Maybe OrderBy
-> Maybe Text -- full text search
-> m (VersionedWithCount NgramsTable)
getTableNgramsDoc' dId tabType listId limit_ offset listType minSize maxSize orderBy _mt = do
ns <- selectNodesWithUsername NodeList userMaster
let ngramsType = ngramsTypeFromTabType tabType
ngs <- selectNgramsByDoc (ns <> [listId]) dId ngramsType
let searchQuery (NgramsTerm nt) = flip S.member (S.fromList ngs) nt
getTableNgrams' NodeDocument dId tabType listId limit_ offset listType minSize maxSize orderBy searchQuery
......@@ -1097,19 +785,12 @@ apiNgramsAsync _dId =
-- * currentVersion: good computation, good bandwidth, bad precision.
-- * listNgramsChangedSince: good precision, good bandwidth, bad computation.
-- * tableNgramsPull: good precision, good bandwidth (if you use the received data!), bad computation.
listNgramsChangedSince :: RepoCmdM env err m
listNgramsChangedSince :: HasNodeStory env err m
=> ListId -> TableNgrams.NgramsType -> Version -> m (Versioned Bool)
listNgramsChangedSince listId ngramsType version
| version < 0 =
Versioned <$> currentVersion <*> pure True
Versioned <$> currentVersion listId <*> pure True
| otherwise =
tableNgramsPull listId ngramsType version & mapped . v_data %~ (== mempty)
listNgramsChangedSince' :: HasNodeStory env err m
=> ListId -> TableNgrams.NgramsType -> Version -> m (Versioned Bool)
listNgramsChangedSince' listId ngramsType version
| version < 0 =
Versioned <$> currentVersion' listId <*> pure True
| otherwise =
tableNgramsPull' listId ngramsType version & mapped . v_data %~ (== mempty)
src/Gargantext/API/Ngrams/List.hs
View file @ 54a4da56
......@@ -24,22 +24,13 @@ import Data.Set (Set)
import Data.Swagger (ToSchema, declareNamedSchema, genericDeclareNamedSchema)
import Data.Text (Text, concat, pack)
import GHC.Generics (Generic)
import Network.HTTP.Media ((//), (/:))
import Servant
import Servant.Job.Async
import Servant.Job.Utils (jsonOptions)
import Web.FormUrlEncoded (FromForm)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Ngrams (getNgramsTableMap, setListNgrams)
import Gargantext.API.Ngrams.Tools (getTermsWith)
import Gargantext.API.Ngrams.Types
import Gargantext.API.Node.Corpus.New.File (FileType(..))
import Gargantext.API.Prelude (GargServer)
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.Terms (ExtractedNgrams(..))
import Gargantext.Core.Text.Terms.WithList (buildPatterns, termsInText)
import Gargantext.Core.Types.Main (ListType(..))
......@@ -54,6 +45,15 @@ import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.Node
import Gargantext.Database.Types (Indexed(..))
import Gargantext.Prelude
import Network.HTTP.Media ((//), (/:))
import Servant
import Servant.Job.Async
import Servant.Job.Utils (jsonOptions)
import Web.FormUrlEncoded (FromForm)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
------------------------------------------------------------------------
-- | TODO refactor
......@@ -110,7 +110,7 @@ csvApi = csvPostAsync
------------------------------------------------------------------------
get :: RepoCmdM env err m =>
get :: HasNodeStory env err m =>
ListId -> m (Headers '[Header "Content-Disposition" Text] NgramsList)
get lId = do
lst <- get' lId
......@@ -121,7 +121,7 @@ get lId = do
]
) lst
get' :: RepoCmdM env err m
get' :: HasNodeStory env err m
=> ListId -> m NgramsList
get' lId = fromList
<$> zip ngramsTypes
......@@ -153,8 +153,8 @@ csvPost l m = do
-----------------------------------------------------------------------------
-- | Re-index documents of a corpus with new ngrams (called orphans here)
reIndexWith :: ( HasRepo env
, FlowCmdM env err m
reIndexWith :: ( HasNodeStory env err m
, FlowCmdM env err m
)
=> CorpusId
-> ListId
......
src/Gargantext/API/Ngrams/Tools.hs
View file @ 54a4da56
......@@ -36,11 +36,6 @@ mergeNgramsElement _neOld neNew = neNew
type RootTerm = NgramsTerm
getRepo :: RepoCmdM env err m => m NgramsRepo
getRepo = do
v <- view repoVar
liftBase $ readMVar v
getRepo' :: HasNodeStory env err m
=> [ListId] -> m NodeListStory
getRepo' listIds = do
......@@ -80,19 +75,8 @@ getNodeListStory'' n = do
listNgramsFromRepo :: [ListId] -> NgramsType
-> NgramsRepo -> HashMap NgramsTerm NgramsRepoElement
listNgramsFromRepo nodeIds ngramsType repo = ngrams
where
ngramsMap = repo ^. r_state . at ngramsType . _Just
-- TODO HashMap linked
ngrams = HM.fromList $ Map.toList $ Map.unionsWith mergeNgramsElement
[ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
listNgramsFromRepo' :: [ListId] -> NgramsType
-> NodeListStory -> HashMap NgramsTerm NgramsRepoElement
listNgramsFromRepo' nodeIds ngramsType repo =
listNgramsFromRepo nodeIds ngramsType repo =
HM.fromList $ Map.toList
$ Map.unionsWith mergeNgramsElement ngrams
where
......@@ -110,41 +94,22 @@ listNgramsFromRepo' nodeIds ngramsType repo =
-- Add a static capability parameter would be nice.
-- Ideally this is the access to `repoVar` which needs to
-- be properly guarded.
getListNgrams :: RepoCmdM env err m
getListNgrams :: HasNodeStory env err m
=> [ListId] -> NgramsType
-> m (HashMap NgramsTerm NgramsRepoElement)
getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
getListNgrams' :: HasNodeStory env err m
=> [ListId] -> NgramsType
-> m (HashMap NgramsTerm NgramsRepoElement)
getListNgrams' nodeIds ngramsType = listNgramsFromRepo' nodeIds ngramsType
getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType
<$> getRepo' nodeIds
getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a)
getTermsWith :: (HasNodeStory env err m, Eq a, Hashable a)
=> (NgramsTerm -> a) -> [ListId]
-> NgramsType -> Set ListType
-> m (HashMap a [a])
getTermsWith f ls ngt lts = HM.fromListWith (<>)
getTermsWith f ls ngt lts = HM.fromListWith (<>)
<$> map toTreeWith
<$> HM.toList
<$> HM.filter (\f' -> Set.member (fst f') lts)
<$> mapTermListRoot ls ngt
<$> getRepo
where
toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of
Nothing -> (f t, [])
Just r -> (f r, [f t])
getTermsWith' :: (HasNodeStory env err m, Eq a, Hashable a)
=> (NgramsTerm -> a) -> [ListId]
-> NgramsType -> Set ListType
-> m (HashMap a [a])
getTermsWith' f ls ngt lts = HM.fromListWith (<>)
<$> map toTreeWith
<$> HM.toList
<$> HM.filter (\f' -> Set.member (fst f') lts)
<$> mapTermListRoot' ls ngt
<$> getRepo' ls
where
toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of
......@@ -153,22 +118,13 @@ getTermsWith' f ls ngt lts = HM.fromListWith (<>)
mapTermListRoot :: [ListId]
-> NgramsType
-> NgramsRepo
-> NodeListStory
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
mapTermListRoot nodeIds ngramsType repo =
(\nre -> (_nre_list nre, _nre_root nre))
<$> listNgramsFromRepo nodeIds ngramsType repo
mapTermListRoot' :: [ListId]
-> NgramsType
-> NodeListStory
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
mapTermListRoot' nodeIds ngramsType repo =
(\nre -> (_nre_list nre, _nre_root nre))
<$> listNgramsFromRepo' nodeIds ngramsType repo
......
src/Gargantext/API/Ngrams/Types.hs
View file @ 54a4da56
......@@ -719,6 +719,7 @@ data RepoEnv = RepoEnv
makeLenses ''RepoEnv
{-
type RepoCmdM env err m =
( CmdM' env err m
, HasRepo env
......@@ -743,7 +744,7 @@ instance HasRepoVar RepoEnv where
repoVar = renv_var
instance HasRepoSaver RepoEnv where
repoSaver = renv_saver
-}
------------------------------------------------------------------------
......
src/Gargantext/API/Node/Corpus/Export.hs
View file @ 54a4da56
......@@ -21,10 +21,11 @@ import Data.Maybe (fromMaybe)
import Data.Set (Set)
import Gargantext.API.Node.Corpus.Export.Types
import Gargantext.API.Ngrams.Types
import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo)
import Gargantext.API.Ngrams.Tools (filterListWithRoot, mapTermListRoot, getRepo')
import Gargantext.API.Prelude (GargNoServer)
import Gargantext.Prelude.Crypto.Hash (hash)
import Gargantext.Core.Types
import Gargantext.Core.NodeStory
import Gargantext.Database.Action.Metrics.NgramsByNode (getNgramsByNodeOnlyUser)
import Gargantext.Database.Admin.Config (userMaster)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
......@@ -57,7 +58,8 @@ getCorpus cId lId nt' = do
ns <- Map.fromList
<$> map (\n -> (_node_id n, n))
<$> selectDocNodes cId
repo <- getRepo
repo <- getRepo' [fromMaybe (panic "[Gargantext.API.Node.Corpus.Export]") lId]
ngs <- getNodeNgrams cId lId nt repo
let -- uniqId is hash computed already for each document imported in database
r = Map.intersectionWith (\a b -> Document a (Ngrams (Set.toList b) (hash b)) (d_hash a b)
......@@ -74,7 +76,7 @@ getNodeNgrams :: HasNodeError err
=> CorpusId
-> Maybe ListId
-> NgramsType
-> NgramsRepo
-> NodeListStory
-> Cmd err (Map NodeId (Set NgramsTerm))
getNodeNgrams cId lId' nt repo = do
lId <- case lId' of
......
src/Gargantext/API/Node/Corpus/New.hs
View file @ 54a4da56
......@@ -18,6 +18,8 @@ New corpus means either:
module Gargantext.API.Node.Corpus.New
where
-- import Servant.Multipart
-- import Test.QuickCheck (elements)
import Control.Lens hiding (elements, Empty)
import Data.Aeson
import Data.Aeson.TH (deriveJSON)
......@@ -25,36 +27,33 @@ import Data.Either
import Data.Maybe (fromMaybe)
import Data.Swagger
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Servant
import Servant.Job.Utils (jsonOptions)
-- import Servant.Multipart
-- import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary
import Gargantext.Prelude
import Gargantext.API.Admin.Orchestrator.Types (JobLog(..), AsyncJobs)
import qualified Gargantext.API.Admin.Orchestrator.Types as T
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Node.Corpus.New.File
import Gargantext.API.Node.Types
import Gargantext.Core (Lang(..){-, allLangs-})
import Gargantext.Database.Action.Mail (sendMail)
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Database.Action.Flow (FlowCmdM, flowCorpus, getDataText, flowDataText, TermType(..), DataOrigin(..){-, allDataOrigins-})
import Gargantext.Database.Action.User (getUserId)
import Gargantext.Database.Action.Flow (flowCorpus, getDataText, flowDataText, TermType(..), DataOrigin(..){-, allDataOrigins-})
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Mail (sendMail)
import Gargantext.Database.Action.Node (mkNodeWithParent)
import Gargantext.Database.Action.User (getUserId)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node (CorpusId, NodeType(..), UserId)
import Gargantext.Database.Query.Table.Node (getNodeWith)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Schema.Node (node_hyperdata)
import qualified Gargantext.Database.GargDB as GargDB
import Gargantext.Prelude
import Servant
import Servant.Job.Utils (jsonOptions)
import Test.QuickCheck.Arbitrary
import qualified Data.Text as T
import qualified Gargantext.API.Admin.Orchestrator.Types as T
import qualified Gargantext.Core.Text.Corpus.API as API
import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileFormat(..), parseFormat)
import qualified Gargantext.Database.GargDB as GargDB
------------------------------------------------------------------------
{-
......
src/Gargantext/API/Prelude.hs
View file @ 54a4da56
......@@ -35,6 +35,7 @@ import Gargantext.API.Admin.Orchestrator.Types
import Gargantext.API.Admin.Types
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types
import Gargantext.Core.NodeStory
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
import Gargantext.Database.Query.Tree
......@@ -51,10 +52,10 @@ joseError = throwError . (_JoseError #)
type EnvC env =
( HasConnectionPool env
, HasRepo env -- TODO rename HasNgramsRepo
, HasSettings env -- TODO rename HasDbSettings
, HasJobEnv env JobLog JobLog
, HasConfig env
, HasNodeStoryEnv env
)
type ErrC err =
......@@ -69,6 +70,7 @@ type ErrC err =
type GargServerC env err m =
( CmdRandom env err m
, HasNodeStory env err m
, EnvC env
, ErrC err
, MimeRender JSON err
......@@ -91,7 +93,7 @@ type GargNoServer t =
type GargNoServer' env err m =
( CmdM env err m
, HasRepo env
, HasNodeStory env err m
, HasSettings env
, HasNodeError err
)
......
src/Gargantext/Core/NodeStory.hs
View file @ 54a4da56
......@@ -15,30 +15,32 @@ Portability : POSIX
module Gargantext.Core.NodeStory where
import System.IO (FilePath, hClose)
import Data.Maybe (fromMaybe)
import Codec.Serialise (Serialise(), serialise, deserialise)
import Control.Monad.Reader
import Control.Monad.Except
import Control.Concurrent (MVar(), withMVar, newMVar)
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Control.Lens (makeLenses, Getter, (^.))
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson hiding ((.=))
import qualified Data.List as List
import Data.Map as Map
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Semigroup
import GHC.Generics (Generic)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (NodeId)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Prelude
import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
import qualified Data.Map.Strict.Patch.Internal as Patch
import qualified Data.ByteString.Lazy as L
import System.Directory (renameFile, createDirectoryIfMissing, doesFileExist)
import System.IO (FilePath, hClose)
import System.IO.Temp (withTempFile)
import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceFreq, debounceAction)
import Gargantext.Database.Prelude (CmdM', HasConnectionPool, HasConfig)
import qualified Data.ByteString.Lazy as L
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Map.Strict.Patch.Internal as Patch
import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
------------------------------------------------------------------------
data NodeStoryEnv = NodeStoryEnv
......@@ -56,6 +58,7 @@ type HasNodeStory env err m = ( CmdM' env err m
, HasNodeStoryEnv env
, HasConfig env
, HasConnectionPool env
, HasNodeError err
)
class (HasNodeStoryVar env, HasNodeStorySaver env)
......
src/Gargantext/Core/Text/List.hs
View file @ 54a4da56
......@@ -23,7 +23,8 @@ import Data.Monoid (mempty)
import Data.Ord (Down(..))
import Data.Set (Set)
import Data.Tuple.Extra (both)
import Gargantext.API.Ngrams.Types (NgramsElement, RepoCmdM, NgramsTerm(..))
import Gargantext.API.Ngrams.Types (NgramsElement, NgramsTerm(..))
import Gargantext.Core.NodeStory
import Gargantext.Core.Text (size)
import Gargantext.Core.Text.List.Group
import Gargantext.Core.Text.List.Group.Prelude
......@@ -38,18 +39,18 @@ import Gargantext.Database.Action.Metrics.TFICF (getTficf)
import Gargantext.Database.Admin.Types.Node (NodeId)
import Gargantext.Database.Prelude (CmdM)
import Gargantext.Database.Query.Table.Ngrams (text2ngrams)
import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Query.Table.NgramsPostag (selectLems)
import Gargantext.Database.Query.Table.Node (defaultList)
import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
import Gargantext.Database.Query.Tree.Error (HasTreeError)
import Gargantext.Database.Schema.Ngrams (NgramsType(..), Ngrams(..))
import Gargantext.Prelude
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
import qualified Data.HashSet as HashSet
{-
-- TODO maybe useful for later
......@@ -61,7 +62,7 @@ isStopTerm (StopSize n) x = Text.length x < n || any isStopChar (Text.unpack x)
-- | TODO improve grouping functions of Authors, Sources, Institutes..
buildNgramsLists :: ( RepoCmdM env err m
buildNgramsLists :: ( HasNodeStory env err m
, CmdM env err m
, HasTreeError err
, HasNodeError err
......@@ -86,7 +87,7 @@ data MapListSize = MapListSize { unMapListSize :: !Int }
buildNgramsOthersList ::( HasNodeError err
, CmdM env err m
, RepoCmdM env err m
, HasNodeStory env err m
, HasTreeError err
)
=> User
......@@ -128,7 +129,7 @@ buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do
getGroupParams :: ( HasNodeError err
, CmdM env err m
, RepoCmdM env err m
, HasNodeStory env err m
, HasTreeError err
)
=> GroupParams -> HashSet Ngrams -> m GroupParams
......@@ -142,7 +143,7 @@ getGroupParams gp _ = pure gp
-- TODO use ListIds
buildNgramsTermsList :: ( HasNodeError err
, CmdM env err m
, RepoCmdM env err m
, HasNodeStory env err m
, HasTreeError err
)
=> User
......
src/Gargantext/Core/Text/List/Social.hs
View file @ 54a4da56
......@@ -16,6 +16,7 @@ import Data.Map (Map)
import Data.Monoid (mconcat)
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.List.Social.Find
import Gargantext.Core.Text.List.Social.History
import Gargantext.Core.Text.List.Social.Patch
......@@ -49,7 +50,7 @@ keepAllParents _ = KeepAllParents True
-}
------------------------------------------------------------------------
flowSocialList :: ( RepoCmdM env err m
flowSocialList :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
......@@ -63,7 +64,7 @@ flowSocialList flowPriority user nt flc =
(flowSocialListPriority flowPriority)
where
flowSocialListByMode' :: ( RepoCmdM env err m
flowSocialListByMode' :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
......@@ -77,7 +78,7 @@ flowSocialList flowPriority user nt flc =
>>= flowSocialListByModeWith nt' flc'
flowSocialListByModeWith :: ( RepoCmdM env err m
flowSocialListByModeWith :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
......@@ -94,10 +95,10 @@ flowSocialList flowPriority user nt flc =
. toFlowListScores (keepAllParents nt'') flc''
-}
-----------------------------------------------------------------
getHistoryScores :: ( RepoCmdM env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
getHistoryScores :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
)
=> History
-> NgramsType
......@@ -107,7 +108,7 @@ getHistoryScores :: ( RepoCmdM env err m
getHistoryScores hist nt fl listes =
addScorePatches nt listes fl <$> getHistory hist nt listes
getHistory :: ( RepoCmdM env err m
getHistory :: ( HasNodeStory env err m
, CmdM env err m
, HasNodeError err
, HasTreeError err
......@@ -115,7 +116,7 @@ getHistory :: ( RepoCmdM env err m
=> History
-> NgramsType
-> [ListId]
-> m (Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch]))
-> m (Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch]))
getHistory hist nt listes =
history hist [nt] listes <$> getRepo
history hist [nt] listes <$> getRepo' listes
src/Gargantext/Core/Text/List/Social/History.hs
View file @ 54a4da56
......@@ -15,12 +15,14 @@ import Control.Lens hiding (cons)
import Data.HashMap.Strict (HashMap)
import Data.Map (Map)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.List.Social.Prelude
import Gargantext.Core.Types (ListId)
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.HashMap.Strict as HasMap
-- TODO put this in Prelude
cons :: a -> [a]
......@@ -37,8 +39,8 @@ data History = History_User
history :: History
-> [NgramsType]
-> [ListId]
-> Repo s NgramsStatePatch
-> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-> NodeStory s NgramsStatePatch'
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
history History_User t l = clean . (history' t l)
where
clean = Map.map (Map.map List.init)
......@@ -53,35 +55,20 @@ history _ t l = history' t l
------------------------------------------------------------------------
history' :: [NgramsType]
-> [ListId]
-> Repo s NgramsStatePatch
-> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
history' types lists = merge
. map (Map.map ( Map.map cons))
. map (Map.map ((Map.filterWithKey (\k _ -> List.elem k lists))))
. map (Map.filterWithKey (\k _ -> List.elem k types))
. map toMap
. view r_history
merge :: [Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])]
-> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
merge = Map.unionsWith merge'
-> NodeStory s NgramsStatePatch'
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
history' types lists = (Map.map (Map.unionsWith (<>)))
. (Map.map (map (Map.filterWithKey (\k _ -> List.elem k types))))
. (Map.map (map toMap))
. (Map.map (view a_history))
. (Map.filterWithKey (\k _ -> List.elem k lists))
. (view unNodeStory)
where
merge' :: Map ListId [HashMap NgramsTerm NgramsPatch]
-> Map ListId [HashMap NgramsTerm NgramsPatch]
-> Map ListId [HashMap NgramsTerm NgramsPatch]
merge' = Map.unionWith (<>)
toMap :: PatchMap NgramsType NgramsTablePatch
-> Map NgramsType [HashMap NgramsTerm NgramsPatch]
toMap m = Map.map (cons . unNgramsTablePatch)
$ unPatchMapToMap m
toMap :: PatchMap NgramsType
(PatchMap ListId
(NgramsTablePatch
)
)
-> Map NgramsType
(Map ListId
(HashMap NgramsTerm NgramsPatch
)
)
toMap = Map.map (Map.map unNgramsTablePatch) . (Map.map unPatchMapToMap) . unPatchMapToMap
src/Gargantext/Core/Text/List/Social/Patch.hs
View file @ 54a4da56
......@@ -30,27 +30,29 @@ import qualified Data.Patch.Class as Patch (Replace(..))
addScorePatches :: NgramsType -> [ListId]
-> FlowCont NgramsTerm FlowListScores
-> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
-> FlowCont NgramsTerm FlowListScores
addScorePatches nt listes fl repo = foldl' (addScorePatchesList nt repo) fl listes
addScorePatches nt listes fl repo =
foldl' (addScorePatchesList nt repo) fl listes
addScorePatchesList :: NgramsType
-> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-- -> Map NgramsType (Map ListId [HashMap NgramsTerm NgramsPatch])
-> Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch])
-> FlowCont NgramsTerm FlowListScores
-> ListId
-> FlowCont NgramsTerm FlowListScores
addScorePatchesList nt repo fl lid = foldl' addScorePatch fl patches
addScorePatchesList nt repo fl lid =
foldl' addScorePatch fl patches
where
patches = maybe [] (List.concat . (map HashMap.toList)) patches'
patches' = do
lists <- Map.lookup nt repo
mapPatches <- Map.lookup lid lists
lists <- Map.lookup lid repo
mapPatches <- Map.lookup nt lists
pure mapPatches
addScorePatch :: FlowCont NgramsTerm FlowListScores
-> (NgramsTerm , NgramsPatch)
-> FlowCont NgramsTerm FlowListScores
......
src/Gargantext/Core/Viz/Chart.hs
View file @ 54a4da56
......@@ -35,7 +35,7 @@ import Gargantext.API.Ngrams.NgramsTree
import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types
import Gargantext.Database.Action.Flow
import Gargantext.Database.Action.Flow.Types
import Gargantext.Database.Action.Metrics.NgramsByNode
import Gargantext.Database.Schema.Ngrams
import Gargantext.Core.Viz.Types
......@@ -59,7 +59,7 @@ chartData :: FlowCmdM env err m
chartData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt <$> getRepo
ts <- mapTermListRoot ls nt <$> getRepo' ls
let
dico = filterListWithRoot lt ts
terms = catMaybes $ List.concat $ map (\(a,b) -> [Just a, b]) $ HashMap.toList dico
......@@ -79,7 +79,7 @@ treeData :: FlowCmdM env err m
treeData cId nt lt = do
ls' <- selectNodesWithUsername NodeList userMaster
ls <- map (_node_id) <$> getListsWithParentId cId
ts <- mapTermListRoot ls nt <$> getRepo
ts <- mapTermListRoot ls nt <$> getRepo' ls
let
dico = filterListWithRoot lt ts
......
src/Gargantext/Core/Viz/Graph/API.hs
View file @ 54a4da56
......@@ -16,11 +16,11 @@ Portability : POSIX
module Gargantext.Core.Viz.Graph.API
where
import Control.Lens (set, (^.), _Just, (^?))
import Control.Lens (set, (^.), _Just, (^?), at, view)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Swagger
import Data.Text
import Data.Text hiding (head)
import Debug.Trace (trace)
import GHC.Generics (Generic)
import Gargantext.API.Admin.Orchestrator.Types
......@@ -28,6 +28,7 @@ import Gargantext.API.Ngrams.Tools
import Gargantext.API.Ngrams.Types (NgramsRepo, r_version)
import Gargantext.API.Prelude
import Gargantext.Core.Methods.Distances (Distance(..), GraphMetric(..), withMetric)
import Gargantext.Core.NodeStory
import Gargantext.Core.Types.Main
import Gargantext.Core.Viz.Graph
import Gargantext.Core.Viz.Graph.GEXF ()
......@@ -48,7 +49,10 @@ import Gargantext.Prelude
import Servant
import Servant.Job.Async
import Servant.XML
import qualified Gargantext.Database.Schema.Node as Node
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
------------------------------------------------------------------------
-- | There is no Delete specific API for Graph since it can be deleted
-- as simple Node.
......@@ -80,7 +84,6 @@ graphAPI u n = getGraph u n
getGraph :: UserId -> NodeId -> GargNoServer HyperdataGraphAPI
getGraph _uId nId = do
nodeGraph <- getNodeWith nId (Proxy :: Proxy HyperdataGraph)
repo <- getRepo
let
graph = nodeGraph ^. node_hyperdata . hyperdataGraph
......@@ -89,6 +92,9 @@ getGraph _uId nId = do
identity
$ nodeGraph ^. node_parent_id
listId <- defaultList cId
repo <- getRepo' [listId]
-- TODO Distance in Graph params
case graph of
Nothing -> do
......@@ -118,9 +124,7 @@ recomputeGraph _uId nId maybeDistance = do
Nothing -> graph ^? _Just . graph_metadata . _Just . gm_metric
_ -> maybeDistance
repo <- getRepo
let
v = repo ^. r_version
cId = maybe (panic "[G.V.G.API.recomputeGraph] Node has no parent")
identity
$ nodeGraph ^. node_parent_id
......@@ -128,6 +132,10 @@ recomputeGraph _uId nId maybeDistance = do
Nothing -> withMetric Order1
Just m -> withMetric m
listId <- defaultList cId
repo <- getRepo' [listId]
let v = repo ^. unNodeStory . at listId . _Just . a_version
case graph of
Nothing -> do
graph' <- computeGraph cId similarity NgramsTerms repo
......@@ -150,7 +158,7 @@ computeGraph :: HasNodeError err
=> CorpusId
-> Distance
-> NgramsType
-> NgramsRepo
-> NodeListStory
-> Cmd err Graph
computeGraph cId d nt repo = do
lId <- defaultList cId
......@@ -175,7 +183,7 @@ computeGraph cId d nt repo = do
defaultGraphMetadata :: HasNodeError err
=> CorpusId
-> Text
-> NgramsRepo
-> NodeListStory
-> GraphMetric
-> Cmd err GraphMetadata
defaultGraphMetadata cId t repo gm = do
......@@ -191,7 +199,7 @@ defaultGraphMetadata cId t repo gm = do
, LegendField 3 "#FFF" "Cluster3"
, LegendField 4 "#FFF" "Cluster4"
]
, _gm_list = (ListForGraph lId (repo ^. r_version))
, _gm_list = (ListForGraph lId (repo ^. unNodeStory . at lId . _Just . a_version))
, _gm_startForceAtlas = True
}
-- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
......@@ -252,8 +260,13 @@ graphVersions nId = do
. gm_list
. lfg_version
repo <- getRepo
let v = repo ^. r_version
cId = maybe (panic "[G.V.G.API] Node has no parent")
identity
$ nodeGraph ^. node_parent_id
listId <- defaultList cId
repo <- getRepo' [listId]
let v = repo ^. unNodeStory . at listId . _Just . a_version
pure $ GraphVersions { gv_graph = listVersion
, gv_repo = v }
......
src/Gargantext/Core/Viz/Phylo/Legacy/LegacyMain.hs
View file @ 54a4da56
......@@ -29,6 +29,7 @@ import Gargantext.Core.Text.Terms.WithList
import Gargantext.Database.Query.Table.Node(defaultList)
import Gargantext.Prelude
import Gargantext.Database.Action.Flow
import Gargantext.Database.Action.Flow.Types
import Gargantext.Core.Viz.LegacyPhylo hiding (Svg, Dot)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Schema.Ngrams (NgramsType(..))
......
src/Gargantext/Database/Action/Flow.hs
View file @ 54a4da56
......@@ -24,8 +24,7 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Action.Flow -- (flowDatabase, ngrams2list)
( FlowCmdM
, getDataText
( getDataText
, flowDataText
, flow
......
src/Gargantext/Database/Action/Flow/List.hs
View file @ 54a4da56
......@@ -18,15 +18,18 @@ module Gargantext.Database.Action.Flow.List
where
import Control.Concurrent
import Control.Lens (view, (^.), (+~), (%~), at)
import Control.Lens (view, (^.), (+~), (%~), at, (.~), _Just)
import Control.Monad.Reader
import Data.Map (Map, toList)
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.API.Ngrams (saveRepo)
import Gargantext.API.Ngrams.Tools (getRepoVar)
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 Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
......@@ -143,7 +146,7 @@ listInsert lId ngs = mapM_ (\(typeList, ngElmts)
-- 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]
......@@ -153,20 +156,18 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
where
m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
putListNgrams' :: (HasInvalidError err, RepoCmdM env err m)
putListNgrams' :: (HasInvalidError err, HasNodeStory env err m)
=> NodeId
-> TableNgrams.NgramsType
-> Map NgramsTerm NgramsRepoElement
-> m ()
putListNgrams' nodeId ngramsType ns = do
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
(p0, p0_validity) = PM.singleton nodeId p1
(p, p_validity) = PM.singleton ngramsType p0
assertValid p0_validity
(p, p_validity) = PM.singleton ngramsType p1
assertValid p_validity
{-
-- TODO
......@@ -178,23 +179,11 @@ putListNgrams' nodeId ngramsType ns = do
-- The modifyMVar_ would test the patch with applicable first.
-- If valid the rest would be atomic and no merge is required.
-}
var <- view repoVar
var <- getRepoVar listId
liftBase $ modifyMVar_ var $ \r -> do
pure $ r & r_version +~ 1
& r_history %~ (p :)
& r_state . at ngramsType %~
(Just .
(at nodeId %~
( Just
. (<> ns)
. something
)
)
. something
)
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
saveRepo
saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
=> m ()
saveRepo = liftBase =<< view repoSaver
src/Gargantext/Database/Action/Flow/Pairing.hs
View file @ 54a4da56
......@@ -16,7 +16,7 @@ module Gargantext.Database.Action.Flow.Pairing
-- (pairing)
where
import Control.Lens (_Just, (^.))
import Control.Lens (_Just, (^.), view)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Maybe (catMaybes, fromMaybe)
......@@ -179,8 +179,8 @@ getNgramsDocId :: CorpusId
-> NgramsType
-> GargNoServer (HashMap DocAuthor (Set NodeId))
getNgramsDocId cId lId nt = do
repo <- getRepo
lIds <- selectNodesWithUsername NodeList userMaster
repo <- getRepo' lIds
let ngs = filterListWithRoot MapTerm $ mapTermListRoot [lId] nt repo
groupNodesByNgrams ngs
......
src/Gargantext/Database/Action/Flow/Types.hs
View file @ 54a4da56
......@@ -25,6 +25,7 @@ import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (HasInvalidError)
import Gargantext.Core.Flow.Types
import Gargantext.Core.Text
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.Terms
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Database.Prelude (CmdM)
......@@ -33,10 +34,9 @@ import Gargantext.Database.Query.Tree.Error (HasTreeError)
type FlowCmdM env err m =
( CmdM env err m
, RepoCmdM env err m
, HasNodeStory env err m
, HasNodeError err
, HasInvalidError err
, HasRepoVar env
, HasTreeError err
)
......
src/Gargantext/Database/Action/Metrics.hs
View file @ 54a4da56
......@@ -15,10 +15,11 @@ module Gargantext.Database.Action.Metrics
import Data.HashMap.Strict (HashMap)
import Data.Vector (Vector)
import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo)
import Gargantext.API.Ngrams.Tools (filterListWithRoot, groupNodesByNgrams, Diagonal(..), getCoocByNgrams, mapTermListRoot, RootTerm, getRepo')
import Gargantext.API.Ngrams.Types (TabType(..), ngramsTypeFromTabType, NgramsTerm)
import Gargantext.Core.Text.Metrics (scored, Scored(..), {-localMetrics, toScored-})
import Gargantext.Core.Types (ListType(..), Limit, NodeType(..))
import Gargantext.Core.NodeStory
import Gargantext.Database.Action.Flow.Types (FlowCmdM)
import Gargantext.Database.Action.Metrics.NgramsByNode (getNodesByNgramsOnlyUser{-, getTficfWith-})
import Gargantext.Database.Admin.Config (userMaster)
......@@ -61,7 +62,7 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
getNgrams :: (FlowCmdM env err m)
getNgrams :: (HasNodeStory env err m)
=> CorpusId -> Maybe ListId -> TabType
-> m ( HashMap NgramsTerm (ListType, Maybe NgramsTerm)
, HashMap NgramsTerm (Maybe RootTerm)
......@@ -72,8 +73,11 @@ getNgrams cId maybeListId tabType = do
Nothing -> defaultList cId
Just lId' -> pure lId'
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo
lists <- mapTermListRoot [lId] (ngramsTypeFromTabType tabType) <$> getRepo' [lId]
let maybeSyn = HM.unions $ map (\t -> filterListWithRoot t lists)
[MapTerm, StopTerm, CandidateTerm]
pure (lists, maybeSyn)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment