[NodeStory] Tools updates (WIP)

src/Gargantext/API/Ngrams/Tools.hs

@@ -28,6 +28,7 @@ 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 Data.List           as List
 import Gargantext.Core.NodeStory
 
 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
@@ -40,24 +41,33 @@ getRepo = do
   v <- view repoVar
   liftBase $ readMVar v
 
-getNodeListStory :: HasNodeStory' env err m
+getRepo' :: HasNodeStory env err m
+         => [ListId] -> m NodeListStory
+getRepo' listIds = do
+  maybeNodeListStory <- head <$> List.reverse <$> mapM getNodeListStory'' listIds
+  case maybeNodeListStory of
+    Nothing  -> panic "[G.A.N.Tools.getRepo']"
+    Just nls -> pure nls 
+
+
+getNodeListStory :: HasNodeStory env err m
                  => m (NodeId -> IO (MVar NodeListStory))
 getNodeListStory = do
   env <- view hasNodeStory
   pure $ view nse_getter env
 
-getNodeListStory' :: HasNodeStory' env err m
+getNodeListStory' :: HasNodeStory env err m
                  => NodeId -> m (IO NodeListStory)
 getNodeListStory' n = do
   f <- getNodeListStory
   v <- liftBase $ f n
   pure $ readMVar v
 
-getNodeListStory'' :: HasNodeStory' env err m
+getNodeListStory'' :: HasNodeStory env err m
                  => NodeId -> m NodeListStory
 getNodeListStory'' n = do
   f <- getNodeListStory
-  v  <- liftBase  $ f n
+  v  <- liftBase $ f n
   v' <- liftBase $ readMVar v
   pure $ v'
 
@@ -74,6 +84,22 @@ listNgramsFromRepo nodeIds ngramsType repo = ngrams
                 [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
 
 
+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
@@ -83,6 +109,13 @@ getListNgrams :: RepoCmdM env err m
               -> 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
+                                 <$> getRepo' nodeIds
+
+
 getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a)
           => (NgramsTerm -> a) -> [ListId]
           -> NgramsType -> Set ListType
@@ -97,6 +130,23 @@ getTermsWith f ls ngt lts = HM.fromListWith (<>)
     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
+      Nothing -> (f t, [])
+      Just  r -> (f r, [f t])
+
+
+
 
 mapTermListRoot :: [ListId]
                 -> NgramsType
@@ -105,6 +155,17 @@ mapTermListRoot :: [ListId]
 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
+
+
+
+
 
 filterListWithRootHashMap :: ListType
                           -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
@@ -146,11 +207,17 @@ groupNodesByNgrams syn occs = HM.fromListWith (<>) occs'
 
 data Diagonal = Diagonal Bool
 
-getCoocByNgrams :: Diagonal -> HashMap NgramsTerm (Set NodeId) -> HashMap (NgramsTerm, NgramsTerm) 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

src/Gargantext/Core/NodeStory.hs

@@ -29,7 +29,6 @@ import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types (NodeId)
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Prelude
-import Control.Monad.Reader
 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
@@ -48,13 +47,14 @@ data NodeStoryEnv = NodeStoryEnv
   }
   deriving (Generic)
 
-type HasNodeStory' env err m = (CmdM' env err m
-                               , HasNodeStory env
+type HasNodeStory env err m = (CmdM' env err m
+                               , HasNodeStoryEnv env
                                , HasConfig env
+                               , HasConnectionPool env
                                )
 
 class (HasNodeStoryVar env, HasNodeStorySaver env)
-  => HasNodeStory env where
+  => HasNodeStoryEnv env where
     hasNodeStory :: Getter env NodeStoryEnv
 
 class HasNodeStoryVar env where
@@ -184,7 +184,7 @@ ngramsStatePatch_migration np' = Map.fromListWith (<>)
   TODO : generalize for any NodeType, let's start with NodeList which
   is implemented already
 -}
-data NodeStory s p = NodeStory { unNodeStory :: Map NodeId (Archive s p) }
+data NodeStory s p = NodeStory { _unNodeStory :: Map NodeId (Archive s p) }
   deriving (Generic, Show)
 
 instance (FromJSON s, FromJSON p) => FromJSON (NodeStory s p)
@@ -239,3 +239,5 @@ initNodeListStoryMock = NodeStory $ Map.singleton nodeListId archive
 ------------------------------------------------------------------------
 -- | Lenses at the bottom of the file because Template Haskell would reorder order of execution in others cases
 makeLenses ''NodeStoryEnv
+makeLenses ''NodeStory
+makeLenses ''Archive