Merge branch 'dev-tree-reload' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell...
[gargantext.git] / src / Gargantext / API / Ngrams / Tools.hs
index ad57701cbfc9cd4d82a7fc6e4b87218e9e6e674c..11c48ae466fd68dd23c66ea6595c035122b2b248 100644 (file)
@@ -9,43 +9,47 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes        #-}
+{-# 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 Data.HashMap.Strict (HashMap)
+import Data.Hashable (Hashable)
 import Data.Set (Set)
-import Data.Text (Text)
 import Data.Validity
-import Gargantext.API.Ngrams
+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
 
+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
-  liftIO $ readMVar v
+  liftBase $ readMVar v
 
 listNgramsFromRepo :: [ListId] -> NgramsType
-                   -> NgramsRepo -> Map Text NgramsRepoElement
+                   -> NgramsRepo -> HashMap 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 ]
+    -- TODO HashMap linked
+    ngrams    = HM.fromList $ Map.toList $ Map.unionsWith mergeNgramsElement
+                [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
+
+
 
 -- TODO-ACCESS: We want to do the security check before entering here.
 --              Add a static capability parameter would be nice.
@@ -53,70 +57,88 @@ listNgramsFromRepo nodeIds ngramsType repo = ngrams
 --              be properly guarded.
 getListNgrams :: RepoCmdM env err m
               => [ListId] -> NgramsType
-              -> m (Map Text NgramsRepoElement)
+              -> m (HashMap NgramsTerm NgramsRepoElement)
 getListNgrams nodeIds ngramsType = listNgramsFromRepo nodeIds ngramsType <$> getRepo
 
-getTermsWith :: (RepoCmdM env err m, Ord a)
-          => (Text -> a ) -> [ListId]
+getTermsWith :: (RepoCmdM env err m, Eq a, Hashable a)
+          => (NgramsTerm -> 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 a [a])
+getTermsWith f ls ngt lt = HM.fromListWith (<>)
+                      <$> map toTreeWith
+                      <$> HM.toList
+                      <$> HM.filter (\f' -> fst f' == lt)
                       <$> mapTermListRoot ls ngt
                       <$> getRepo
   where
-    toTreeWith f'' (t, (_lt, maybeRoot)) = case maybeRoot of
-      Nothing -> (f'' t, [])
-      Just  r -> (f'' r, map f'' [t])
-
-mapTermListRoot :: [ListId] -> NgramsType
-                -> NgramsRepo -> Map Text (ListType, (Maybe Text))
+    toTreeWith (t, (_lt, maybeRoot)) = case maybeRoot of
+      Nothing -> (f t, [])
+      Just  r -> (f r, [f t])
+
+mapTermListRoot :: [ListId]
+                -> NgramsType
+                -> NgramsRepo
+                -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
 mapTermListRoot nodeIds ngramsType repo =
-  Map.fromList [ (t, (_nre_list nre, _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 isGraphTerm (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
-    isGraphTerm (_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 -> l == lt
+      Just  r -> case HM.lookup r m of
+        Nothing -> panic $ "Garg.API.Ngrams.Tools: filterWithRoot, unknown key: " <> unNgramsTerm r
+        Just  (l',_) -> 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