-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
module Gargantext.API.Ngrams.Tools
where
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
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)
]
-
-