refactoring 2021, remove old phylo files, keep API
[gargantext.git] / src / Gargantext / API / Ngrams / Tools.hs
index b00e868e73101ef5302d2530cb113cb9d33b3a3c..5ee381ee5ed60dfab90c0726c720c77c04eb6a88 100644 (file)
@@ -9,9 +9,6 @@ Portability : POSIX
 
 -}
 
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes        #-}
 
 module Gargantext.API.Ngrams.Tools
   where
@@ -20,51 +17,78 @@ import Control.Concurrent
 import Control.Lens (_Just, (^.), at, view)
 import Control.Monad.Reader
 import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
 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.Map.Strict as Map
-import qualified Data.Set as Set
 
+mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
+mergeNgramsElement _neOld neNew = neNew
 
 type RootTerm = Text
 
+getRepo :: RepoCmdM env err m => m NgramsRepo
+getRepo = do
+  v <- view repoVar
+  liftBase $ readMVar v
 
-getListNgrams :: RepoCmdM env err m
-               => [ListId] -> NgramsType
-               -> m (Map Text NgramsRepoElement)
-getListNgrams nodeIds ngramsType = do
-  v    <- view repoVar
-  repo <- liftIO $ readMVar v
-
-  let
+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 ]
-
-  pure ngrams
+                [ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
 
-mapTermListRoot :: RepoCmdM env err m
-               => [ListId] -> NgramsType
-               -> m (Map Text (ListType, (Maybe Text)))
-mapTermListRoot nodeIds ngramsType = do
-  ngrams <- getListNgrams nodeIds ngramsType
-  pure $ Map.fromList [(t, (_nre_list nre, _nre_root nre))
-                      | (t, nre) <- Map.toList ngrams
-                      ]
+-- 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
+              => [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)
+                      <$> 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))
+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 :: 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)
+                    $ filter isMapTerm (Map.toList m)
   where
-    isGraphTerm (_t,(l, maybeRoot)) = case maybeRoot of
+    isMapTerm (_t,(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
@@ -90,14 +114,12 @@ getCoocByNgrams = getCoocByNgrams' identity
 
 getCoocByNgrams' :: (Ord a, Ord c) => (b -> Set c) -> Diagonal -> Map a b -> Map (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)
+  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)
                ]
 
-
-