-}
+{-# 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
+ ]
-- 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
+
+------------------------------------------