[mail] some small refactoring
[gargantext.git] / src / Gargantext / API / Ngrams / Tools.hs
index d4dfc1c38266ede03a1191f92f83cf5447a2c965..0491cafdae07c621b314eb35a9e507cdb4433610 100644 (file)
@@ -9,43 +9,79 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE TypeFamilies #-}
 
 module Gargantext.API.Ngrams.Tools
   where
 
 import Control.Concurrent
-import Control.Lens (_Just, (^.), at, view)
+import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
 import Control.Monad.Reader
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
+import Data.HashMap.Strict (HashMap)
+import Data.Hashable (Hashable)
 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.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 Gargantext.Core.NodeStory
 
 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
 mergeNgramsElement _neOld neNew = neNew
 
-type RootTerm = Text
+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
+  f <- getNodeListStory
+  v  <- liftBase $ f listIds
+  v' <- liftBase $ readMVar v
+  pure $ v'
+
+
+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
-                   -> NgramsRepo -> Map Text NgramsRepoElement
-listNgramsFromRepo nodeIds ngramsType repo = Map.mapKeys unNgramsTerm ngrams
-  where
-    ngramsMap = repo ^. r_state . at ngramsType . _Just
 
-    ngrams    = Map.unionsWith mergeNgramsElement
-                [ 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
+                ]
 
 
 
@@ -53,75 +89,105 @@ listNgramsFromRepo nodeIds ngramsType repo = Map.mapKeys unNgramsTerm ngrams
 --              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 Text NgramsRepoElement)
-getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
-
-getTermsWith :: (RepoCmdM env err m, Ord a)
-          => (Text -> a ) -> [ListId]
-          -> NgramsType -> ListType
-          -> m (Map a [a])
-getTermsWith f ls ngt lt = Map.fromListWith (<>)
-                      <$> map (toTreeWith f)
-                      <$> Map.toList
-                      <$> Map.filter (\f' -> (fst f') == lt)
+              -> m (HashMap NgramsTerm NgramsRepoElement)
+getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType
+                                 <$> getRepo' nodeIds
+
+
+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
+                      <$> getRepo' ls
   where
-    toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of
-      Nothing -> (f'' t, [])
-      Just  r -> (f'' r, map f'' [t])
+    toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of
+      Nothing -> (f t, [])
+      Just  r -> (f r, [f t])
+
+
 
 mapTermListRoot :: [ListId]
                 -> NgramsType
-                -> NgramsRepo
-                -> Map Text (ListType, (Maybe Text))
+                -> NodeListStory
+                -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
 mapTermListRoot nodeIds ngramsType repo =
-  Map.fromList [ (t, (_nre_list nre, unNgramsTerm <$> _nre_root nre))
-               | (t, nre) <- Map.toList ngrams
-               ]
-  where ngrams = listNgramsFromRepo nodeIds ngramsType repo
-
-filterListWithRoot :: ListType
-                   -> Map Text (ListType, Maybe Text)
-                   -> Map Text (Maybe RootTerm)
-filterListWithRoot lt m = Map.fromList
-                    $ map (\(t,(_,r)) -> (t,r))
-                    $ filter isMapTerm (Map.toList m)
+      (\nre -> (_nre_list nre, _nre_root nre))
+  <$> listNgramsFromRepo nodeIds ngramsType repo
+
+
+
+
+filterListWithRootHashMap :: ListType
+                          -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
+                          -> HashMap NgramsTerm (Maybe RootTerm)
+filterListWithRootHashMap lt m = snd <$> HM.filter isMapTerm m
   where
-    isMapTerm (_t,(l, maybeRoot)) = case maybeRoot of
+    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: " <> r
+      Just  r -> case HM.lookup r m of
+        Nothing -> panic $ "[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " <> unNgramsTerm r
         Just  (l',_) -> l' == lt
 
-groupNodesByNgrams :: Map Text (Maybe RootTerm)
-                   -> Map Text (Set NodeId)
-                   -> Map Text (Set NodeId)
-groupNodesByNgrams syn occs = Map.fromListWith (<>) occs'
+filterListWithRoot :: [ListType]
+                   -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
+                   -> HashMap NgramsTerm (Maybe RootTerm)
+filterListWithRoot lt m = snd <$> HM.filter isMapTerm m
   where
-    occs' = map toSyn (Map.toList occs)
-    toSyn (t,ns) = case Map.lookup t syn of
-      Nothing -> panic $ "[Garg.API.Ngrams.Tools.groupNodesByNgrams] unknown key: " <> t
+    isMapTerm (l, maybeRoot) = case maybeRoot of
+      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
+                      , IxValue root_map ~ Maybe RootTerm
+                      )
+                   => root_map
+                   -> HashMap NgramsTerm (Set NodeId)
+                   -> HashMap NgramsTerm (Set NodeId)
+groupNodesByNgrams syn occs = HM.fromListWith (<>) occs'
+  where
+    occs' = map toSyn (HM.toList occs)
+    toSyn (t,ns) = case syn ^. at t of
+      Nothing -> panic $ "[Garg.API.Ngrams.Tools.groupNodesByNgrams] unknown key: " <> unNgramsTerm t
       Just  r -> case r of
         Nothing  -> (t, ns)
         Just  r' -> (r',ns)
 
 data Diagonal = Diagonal Bool
 
-getCoocByNgrams :: Diagonal -> Map Text (Set NodeId) -> Map (Text, Text) Int
+getCoocByNgrams :: Diagonal
+                -> HashMap NgramsTerm (Set NodeId)
+                -> HashMap (NgramsTerm, NgramsTerm) Int
 getCoocByNgrams = getCoocByNgrams' identity
 
 
-getCoocByNgrams' :: (Ord a, Ord c) => (b -> Set c) -> Diagonal -> Map a b -> Map (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 =
-  Map.fromList [( (t1,t2)
-                , maybe 0 Set.size $ Set.intersection
-                                  <$> (fmap f $ Map.lookup t1 m)
-                                  <*> (fmap f $ Map.lookup t2 m)
-                ) | (t1,t2) <- case diag of
-                                 True   -> [ (x,y) | x <- Map.keys m, y <- Map.keys m, x <= y]
-                                 False  -> listToCombi identity (Map.keys 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
+              ]
+
+  where ks = HM.keys m
+
+------------------------------------------