import Control.Concurrent
import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
import Control.Monad.Reader
-import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HM
-import Gargantext.Data.HashMap.Strict.Utils as HM
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
+import Data.Hashable (Hashable)
+import Data.Pool (withResource)
import Data.Set (Set)
-import Data.Text (Text)
import Data.Validity
-
import Gargantext.API.Ngrams.Types
-import Gargantext.Core.Types (ListType(..), NodeId, ListId)
+import Gargantext.Core.NodeStory
+import Gargantext.Core.Types (ListType(..), NodeId, NodeType(..), ListId)
+import Gargantext.Database.Prelude (CmdM, HasConnectionPool(..))
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Prelude
+import qualified Data.HashMap.Strict as HM
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Gargantext.Core.NodeStoryFile as NSF
+
mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
mergeNgramsElement _neOld neNew = neNew
type RootTerm = NgramsTerm
-getRepo :: RepoCmdM env err m => m NgramsRepo
-getRepo = do
- v <- view repoVar
- liftBase $ readMVar v
-listNgramsFromRepo :: [ListId] -> NgramsType
- -> NgramsRepo -> Map NgramsTerm NgramsRepoElement
-listNgramsFromRepo nodeIds ngramsType repo = ngrams
- where
- ngramsMap = repo ^. r_state . at ngramsType . _Just
-
- ngrams = Map.unionsWith mergeNgramsElement
- [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
+getRepo :: HasNodeStory env err m
+ => [ListId] -> m NodeListStory
+getRepo listIds = do
+ f <- getNodeListStory
+ v <- liftBase $ f listIds
+ v' <- liftBase $ readMVar v
+ pure $ v'
+repoSize :: Ord k1 => NodeStory (Map.Map k1 (Map.Map k2 a)) p
+ -> NodeId
+ -> Map.Map k1 Int
+repoSize repo node_id = Map.map Map.size state
+ where
+ state = repo ^. unNodeStory
+ . at node_id . _Just
+ . a_state
+
+
+getNodeStoryVar :: HasNodeStory env err m
+ => [ListId] -> m (MVar NodeListStory)
+getNodeStoryVar l = do
+ f <- getNodeListStory
+ v <- liftBase $ f l
+ pure v
+
+
+getNodeListStory :: HasNodeStory env err m
+ => m ([NodeId] -> IO (MVar NodeListStory))
+getNodeListStory = do
+ env <- view hasNodeStory
+ pure $ view nse_getter env
+
+
+
+listNgramsFromRepo :: [ListId]
+ -> NgramsType
+ -> NodeListStory
+ -> HashMap NgramsTerm NgramsRepoElement
+listNgramsFromRepo nodeIds ngramsType repo =
+ HM.fromList $ Map.toList
+ $ Map.unionsWith mergeNgramsElement ngrams
+ where
+ ngrams = [ repo
+ ^. unNodeStory
+ . at nodeId . _Just
+ . a_state
+ . at ngramsType . _Just
+ | nodeId <- nodeIds
+ ]
-- TODO-ACCESS: We want to do the security check before entering here.
-- 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 (Map NgramsTerm NgramsRepoElement)
-getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
+ -> m (HashMap NgramsTerm NgramsRepoElement)
+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 -> ListType
+ -> NgramsType -> Set ListType
-> m (HashMap a [a])
-getTermsWith f ls ngt lt = HM.fromListWith (<>)
+getTermsWith f ls ngt lts = HM.fromListWith (<>)
<$> map toTreeWith
- <$> Map.toList
- <$> Map.filter (\f' -> fst f' == lt)
+ <$> HM.toList
+ <$> HM.filter (\f' -> Set.member (fst f') lts)
<$> mapTermListRoot ls ngt
- <$> getRepo
+ <$> getRepo ls
where
toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of
Nothing -> (f t, [])
Just r -> (f r, [f t])
+
+
mapTermListRoot :: [ListId]
-> NgramsType
- -> NgramsRepo
- -> Map NgramsTerm (ListType, Maybe NgramsTerm)
+ -> NodeListStory
+ -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
mapTermListRoot nodeIds ngramsType repo =
- (\nre -> (_nre_list nre, _nre_root nre)) <$>
- listNgramsFromRepo nodeIds ngramsType repo
+ (\nre -> (_nre_list nre, _nre_root nre))
+ <$> listNgramsFromRepo nodeIds ngramsType repo
+
+
+
filterListWithRootHashMap :: ListType
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
isMapTerm (l, maybeRoot) = case maybeRoot of
Nothing -> l == lt
Just r -> case HM.lookup r m of
- Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> unNgramsTerm r
+ Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
Just (l',_) -> l' == lt
-filterListWithRoot :: ListType
- -> Map NgramsTerm (ListType, Maybe NgramsTerm)
- -> Map NgramsTerm (Maybe RootTerm)
-filterListWithRoot lt m = snd <$> Map.filter isMapTerm m
+filterListWithRoot :: [ListType]
+ -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
+ -> HashMap NgramsTerm (Maybe RootTerm)
+filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
where
isMapTerm (l, maybeRoot) = case maybeRoot of
- Nothing -> l == lt
- Just r -> case Map.lookup r m of
- Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> unNgramsTerm r
- Just (l',_) -> l' == lt
+ Nothing -> elem l lt
+ Just r -> case HM.lookup r m of
+ Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
+ Just (l',_) -> elem l' lt
groupNodesByNgrams :: ( At root_map
, Index root_map ~ NgramsTerm
data Diagonal = Diagonal Bool
-getCoocByNgrams :: Diagonal -> HashMap Text (Set NodeId) -> HashMap (Text, Text) Int
+getCoocByNgrams :: Diagonal
+ -> HashMap NgramsTerm (Set NodeId)
+ -> HashMap (NgramsTerm, NgramsTerm) Int
getCoocByNgrams = getCoocByNgrams' identity
-getCoocByNgrams' :: (Hashable a, Ord a, Ord c) => (b -> Set c) -> Diagonal -> HashMap a b -> HashMap (a, a) Int
+getCoocByNgrams' :: (Hashable a, Ord a, Ord c)
+ => (b -> Set c)
+ -> Diagonal
+ -> HashMap a b
+ -> HashMap (a, a) Int
getCoocByNgrams' f (Diagonal diag) m =
HM.fromList [( (t1,t2)
, maybe 0 Set.size $ Set.intersection
<$> (fmap f $ HM.lookup t1 m)
<*> (fmap f $ HM.lookup t2 m)
)
- | (t1,t2) <- if diag then
- [ (x,y) | x <- ks, y <- ks, x <= y] -- TODO if we keep a Data.Map here it might be
- -- more efficient to enumerate all the y <= x.
- else
- listToCombi identity ks
+ | (t1,t2) <- if diag
+ then [ (x,y) | x <- ks, y <- ks, x <= y]
+ -- TODO if we keep a Data.Map here it might be
+ -- more efficient to enumerate all the y <= x.
+ else
+ listToCombi identity ks
]
- where ks = HM.keys m
\ No newline at end of file
+ where
+ ks = HM.keys m
+
+-- TODO k could be either k1 or k2 here
+getCoocByNgrams'' :: (Hashable k, Ord k, Ord contexts)
+ => Diagonal
+ -> (contextA -> Set contexts, contextB -> Set contexts)
+ -> (HashMap k contextA, HashMap k contextB)
+ -> HashMap (k, k) Int
+getCoocByNgrams'' (Diagonal diag) (f1,f2) (m1,m2) =
+ HM.fromList [( (t1,t2)
+ , maybe 0 Set.size $ Set.intersection
+ <$> (fmap f1 $ HM.lookup t1 m1)
+ <*> (fmap f2 $ HM.lookup t2 m2)
+ )
+ | (t1,t2) <- if diag
+ then
+ [ (x,y) | x <- ks1, y <- ks2, x <= y]
+ -- TODO if we keep a Data.Map here it might be
+ -- more efficient to enumerate all the y <= x.
+ else
+ [ (x,y) | x <- ks1, y <- ks2, x < y]
+ -- TODO check optim
+ -- listToCombi identity ks1
+ ]
+ where
+ ks1 = HM.keys m1
+ ks2 = HM.keys m2
+
+
+
+------------------------------------------
+
+
+migrateFromDirToDb :: (CmdM env err m) -- , HasNodeStory env err m)
+ => m ()
+migrateFromDirToDb = do
+ pool <- view connPool
+ withResource pool $ \c -> do
+ listIds <- liftBase $ getNodesIdWithType c NodeList
+ printDebug "[migrateFromDirToDb] listIds" listIds
+ (NodeStory nls) <- NSF.getRepoReadConfig listIds
+ printDebug "[migrateFromDirToDb] nls" nls
+ _ <- mapM (\(nId, a) -> do
+ n <- liftBase $ nodeExists c nId
+ case n of
+ False -> pure ()
+ True -> liftBase $ upsertNodeStories c nId a
+ ) $ Map.toList nls
+ --_ <- nodeStoryIncs (Just $ NodeStory nls) listIds
+ pure ()