{-|
Module      : Gargantext.API.Ngrams.Tools
Description : Tools to manage Ngrams Elements (from the API)
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

{-# LANGUAGE TypeFamilies #-}

module Gargantext.API.Ngrams.Tools
  where

import Control.Concurrent
import Control.Lens (_Just, (^.), at, view, At, Index, IxValue)
import Control.Monad.Reader
import Data.HashMap.Strict (HashMap)
import Data.Hashable (Hashable)
import Data.Set (Set)
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 :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
mergeNgramsElement NgramsRepoElement
_neOld NgramsRepoElement
neNew = NgramsRepoElement
neNew

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' :: [ListId] -> m NodeListStory
getRepo' [ListId]
listIds = do
  [ListId] -> IO (MVar NodeListStory)
f <- m ([ListId] -> IO (MVar NodeListStory))
forall env err (m :: * -> *).
HasNodeStory env err m =>
m ([ListId] -> IO (MVar NodeListStory))
getNodeListStory
  MVar NodeListStory
v  <- IO (MVar NodeListStory) -> m (MVar NodeListStory)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (MVar NodeListStory) -> m (MVar NodeListStory))
-> IO (MVar NodeListStory) -> m (MVar NodeListStory)
forall a b. (a -> b) -> a -> b
$ [ListId] -> IO (MVar NodeListStory)
f [ListId]
listIds
  NodeListStory
v' <- IO NodeListStory -> m NodeListStory
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO NodeListStory -> m NodeListStory)
-> IO NodeListStory -> m NodeListStory
forall a b. (a -> b) -> a -> b
$ MVar NodeListStory -> IO NodeListStory
forall a. MVar a -> IO a
readMVar MVar NodeListStory
v
  NodeListStory -> m NodeListStory
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeListStory -> m NodeListStory)
-> NodeListStory -> m NodeListStory
forall a b. (a -> b) -> a -> b
$ NodeListStory
v'


getNodeStoryVar :: HasNodeStory env err m
           => [ListId] -> m (MVar NodeListStory)
getNodeStoryVar :: [ListId] -> m (MVar NodeListStory)
getNodeStoryVar [ListId]
l = do
  [ListId] -> IO (MVar NodeListStory)
f <- m ([ListId] -> IO (MVar NodeListStory))
forall env err (m :: * -> *).
HasNodeStory env err m =>
m ([ListId] -> IO (MVar NodeListStory))
getNodeListStory
  MVar NodeListStory
v  <- IO (MVar NodeListStory) -> m (MVar NodeListStory)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (MVar NodeListStory) -> m (MVar NodeListStory))
-> IO (MVar NodeListStory) -> m (MVar NodeListStory)
forall a b. (a -> b) -> a -> b
$ [ListId] -> IO (MVar NodeListStory)
f [ListId]
l
  MVar NodeListStory -> m (MVar NodeListStory)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVar NodeListStory
v


getNodeListStory :: HasNodeStory env err m
                 => m ([NodeId] -> IO (MVar NodeListStory))
getNodeListStory :: m ([ListId] -> IO (MVar NodeListStory))
getNodeListStory = do
  NodeStoryEnv
env <- Getting NodeStoryEnv env NodeStoryEnv -> m NodeStoryEnv
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting NodeStoryEnv env NodeStoryEnv
forall env. HasNodeStoryEnv env => Getter env NodeStoryEnv
hasNodeStory
  ([ListId] -> IO (MVar NodeListStory))
-> m ([ListId] -> IO (MVar NodeListStory))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([ListId] -> IO (MVar NodeListStory))
 -> m ([ListId] -> IO (MVar NodeListStory)))
-> ([ListId] -> IO (MVar NodeListStory))
-> m ([ListId] -> IO (MVar NodeListStory))
forall a b. (a -> b) -> a -> b
$ Getting
  ([ListId] -> IO (MVar NodeListStory))
  NodeStoryEnv
  ([ListId] -> IO (MVar NodeListStory))
-> NodeStoryEnv -> [ListId] -> IO (MVar NodeListStory)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  ([ListId] -> IO (MVar NodeListStory))
  NodeStoryEnv
  ([ListId] -> IO (MVar NodeListStory))
Lens' NodeStoryEnv ([ListId] -> IO (MVar NodeListStory))
nse_getter NodeStoryEnv
env



listNgramsFromRepo :: [ListId]
                   -> NgramsType
                   -> NodeListStory
                   -> HashMap NgramsTerm NgramsRepoElement
listNgramsFromRepo :: [ListId]
-> NgramsType
-> NodeListStory
-> HashMap NgramsTerm NgramsRepoElement
listNgramsFromRepo [ListId]
nodeIds NgramsType
ngramsType NodeListStory
repo =
  [(NgramsTerm, NgramsRepoElement)]
-> HashMap NgramsTerm NgramsRepoElement
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(NgramsTerm, NgramsRepoElement)]
 -> HashMap NgramsTerm NgramsRepoElement)
-> [(NgramsTerm, NgramsRepoElement)]
-> HashMap NgramsTerm NgramsRepoElement
forall a b. (a -> b) -> a -> b
$ Map NgramsTerm NgramsRepoElement
-> [(NgramsTerm, NgramsRepoElement)]
forall k a. Map k a -> [(k, a)]
Map.toList
              (Map NgramsTerm NgramsRepoElement
 -> [(NgramsTerm, NgramsRepoElement)])
-> Map NgramsTerm NgramsRepoElement
-> [(NgramsTerm, NgramsRepoElement)]
forall a b. (a -> b) -> a -> b
$ (NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement)
-> [Map NgramsTerm NgramsRepoElement]
-> Map NgramsTerm NgramsRepoElement
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
mergeNgramsElement [Map NgramsTerm NgramsRepoElement]
ngrams
    where
      ngrams :: [Map NgramsTerm NgramsRepoElement]
ngrams = [ NodeListStory
repo
               NodeListStory
-> Getting
     (Map NgramsTerm NgramsRepoElement)
     NodeListStory
     (Map NgramsTerm NgramsRepoElement)
-> Map NgramsTerm NgramsRepoElement
forall s a. s -> Getting a s a -> a
^. (Map ListId (Archive NgramsState' NgramsStatePatch')
 -> Const
      (Map NgramsTerm NgramsRepoElement)
      (Map ListId (Archive NgramsState' NgramsStatePatch')))
-> NodeListStory
-> Const (Map NgramsTerm NgramsRepoElement) NodeListStory
forall s1 p1 s2 p2.
Iso
  (NodeStory s1 p1)
  (NodeStory s2 p2)
  (Map ListId (Archive s1 p1))
  (Map ListId (Archive s2 p2))
unNodeStory
                ((Map ListId (Archive NgramsState' NgramsStatePatch')
  -> Const
       (Map NgramsTerm NgramsRepoElement)
       (Map ListId (Archive NgramsState' NgramsStatePatch')))
 -> NodeListStory
 -> Const (Map NgramsTerm NgramsRepoElement) NodeListStory)
-> ((Map NgramsTerm NgramsRepoElement
     -> Const
          (Map NgramsTerm NgramsRepoElement)
          (Map NgramsTerm NgramsRepoElement))
    -> Map ListId (Archive NgramsState' NgramsStatePatch')
    -> Const
         (Map NgramsTerm NgramsRepoElement)
         (Map ListId (Archive NgramsState' NgramsStatePatch')))
-> Getting
     (Map NgramsTerm NgramsRepoElement)
     NodeListStory
     (Map NgramsTerm NgramsRepoElement)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map ListId (Archive NgramsState' NgramsStatePatch'))
-> Lens'
     (Map ListId (Archive NgramsState' NgramsStatePatch'))
     (Maybe
        (IxValue (Map ListId (Archive NgramsState' NgramsStatePatch'))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map ListId (Archive NgramsState' NgramsStatePatch'))
ListId
nodeId ((Maybe (Archive NgramsState' NgramsStatePatch')
  -> Const
       (Map NgramsTerm NgramsRepoElement)
       (Maybe (Archive NgramsState' NgramsStatePatch')))
 -> Map ListId (Archive NgramsState' NgramsStatePatch')
 -> Const
      (Map NgramsTerm NgramsRepoElement)
      (Map ListId (Archive NgramsState' NgramsStatePatch')))
-> ((Map NgramsTerm NgramsRepoElement
     -> Const
          (Map NgramsTerm NgramsRepoElement)
          (Map NgramsTerm NgramsRepoElement))
    -> Maybe (Archive NgramsState' NgramsStatePatch')
    -> Const
         (Map NgramsTerm NgramsRepoElement)
         (Maybe (Archive NgramsState' NgramsStatePatch')))
-> (Map NgramsTerm NgramsRepoElement
    -> Const
         (Map NgramsTerm NgramsRepoElement)
         (Map NgramsTerm NgramsRepoElement))
-> Map ListId (Archive NgramsState' NgramsStatePatch')
-> Const
     (Map NgramsTerm NgramsRepoElement)
     (Map ListId (Archive NgramsState' NgramsStatePatch'))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Archive NgramsState' NgramsStatePatch'
 -> Const
      (Map NgramsTerm NgramsRepoElement)
      (Archive NgramsState' NgramsStatePatch'))
-> Maybe (Archive NgramsState' NgramsStatePatch')
-> Const
     (Map NgramsTerm NgramsRepoElement)
     (Maybe (Archive NgramsState' NgramsStatePatch'))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just
                ((Archive NgramsState' NgramsStatePatch'
  -> Const
       (Map NgramsTerm NgramsRepoElement)
       (Archive NgramsState' NgramsStatePatch'))
 -> Maybe (Archive NgramsState' NgramsStatePatch')
 -> Const
      (Map NgramsTerm NgramsRepoElement)
      (Maybe (Archive NgramsState' NgramsStatePatch')))
-> ((Map NgramsTerm NgramsRepoElement
     -> Const
          (Map NgramsTerm NgramsRepoElement)
          (Map NgramsTerm NgramsRepoElement))
    -> Archive NgramsState' NgramsStatePatch'
    -> Const
         (Map NgramsTerm NgramsRepoElement)
         (Archive NgramsState' NgramsStatePatch'))
-> (Map NgramsTerm NgramsRepoElement
    -> Const
         (Map NgramsTerm NgramsRepoElement)
         (Map NgramsTerm NgramsRepoElement))
-> Maybe (Archive NgramsState' NgramsStatePatch')
-> Const
     (Map NgramsTerm NgramsRepoElement)
     (Maybe (Archive NgramsState' NgramsStatePatch'))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NgramsState'
 -> Const (Map NgramsTerm NgramsRepoElement) NgramsState')
-> Archive NgramsState' NgramsStatePatch'
-> Const
     (Map NgramsTerm NgramsRepoElement)
     (Archive NgramsState' NgramsStatePatch')
forall s1 p s2. Lens (Archive s1 p) (Archive s2 p) s1 s2
a_state
                ((NgramsState'
  -> Const (Map NgramsTerm NgramsRepoElement) NgramsState')
 -> Archive NgramsState' NgramsStatePatch'
 -> Const
      (Map NgramsTerm NgramsRepoElement)
      (Archive NgramsState' NgramsStatePatch'))
-> ((Map NgramsTerm NgramsRepoElement
     -> Const
          (Map NgramsTerm NgramsRepoElement)
          (Map NgramsTerm NgramsRepoElement))
    -> NgramsState'
    -> Const (Map NgramsTerm NgramsRepoElement) NgramsState')
-> (Map NgramsTerm NgramsRepoElement
    -> Const
         (Map NgramsTerm NgramsRepoElement)
         (Map NgramsTerm NgramsRepoElement))
-> Archive NgramsState' NgramsStatePatch'
-> Const
     (Map NgramsTerm NgramsRepoElement)
     (Archive NgramsState' NgramsStatePatch')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index NgramsState'
-> Lens' NgramsState' (Maybe (IxValue NgramsState'))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index NgramsState'
NgramsType
ngramsType ((Maybe (Map NgramsTerm NgramsRepoElement)
  -> Const
       (Map NgramsTerm NgramsRepoElement)
       (Maybe (Map NgramsTerm NgramsRepoElement)))
 -> NgramsState'
 -> Const (Map NgramsTerm NgramsRepoElement) NgramsState')
-> ((Map NgramsTerm NgramsRepoElement
     -> Const
          (Map NgramsTerm NgramsRepoElement)
          (Map NgramsTerm NgramsRepoElement))
    -> Maybe (Map NgramsTerm NgramsRepoElement)
    -> Const
         (Map NgramsTerm NgramsRepoElement)
         (Maybe (Map NgramsTerm NgramsRepoElement)))
-> (Map NgramsTerm NgramsRepoElement
    -> Const
         (Map NgramsTerm NgramsRepoElement)
         (Map NgramsTerm NgramsRepoElement))
-> NgramsState'
-> Const (Map NgramsTerm NgramsRepoElement) NgramsState'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map NgramsTerm NgramsRepoElement
 -> Const
      (Map NgramsTerm NgramsRepoElement)
      (Map NgramsTerm NgramsRepoElement))
-> Maybe (Map NgramsTerm NgramsRepoElement)
-> Const
     (Map NgramsTerm NgramsRepoElement)
     (Maybe (Map NgramsTerm NgramsRepoElement))
forall a b. Prism (Maybe a) (Maybe b) a b
_Just
                | ListId
nodeId <- [ListId]
nodeIds
                ]



-- 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 :: HasNodeStory env err m
              => [ListId] -> NgramsType
              -> m (HashMap NgramsTerm NgramsRepoElement)
getListNgrams :: [ListId] -> NgramsType -> m (HashMap NgramsTerm NgramsRepoElement)
getListNgrams [ListId]
nodeIds NgramsType
ngramsType = [ListId]
-> NgramsType
-> NodeListStory
-> HashMap NgramsTerm NgramsRepoElement
listNgramsFromRepo [ListId]
nodeIds NgramsType
ngramsType
                                 (NodeListStory -> HashMap NgramsTerm NgramsRepoElement)
-> m NodeListStory -> m (HashMap NgramsTerm NgramsRepoElement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ListId] -> m NodeListStory
forall env err (m :: * -> *).
HasNodeStory env err m =>
[ListId] -> m NodeListStory
getRepo' [ListId]
nodeIds


getTermsWith :: (HasNodeStory env err m, Eq a, Hashable a)
          => (NgramsTerm -> a) -> [ListId]
          -> NgramsType -> Set ListType
          -> m (HashMap a [a])
getTermsWith :: (NgramsTerm -> a)
-> [ListId] -> NgramsType -> Set ListType -> m (HashMap a [a])
getTermsWith NgramsTerm -> a
f [ListId]
ls NgramsType
ngt Set ListType
lts  = ([a] -> [a] -> [a]) -> [(a, [a])] -> HashMap a [a]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HM.fromListWith [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
(<>)
                      ([(a, [a])] -> HashMap a [a])
-> ([(NgramsTerm, (ListType, Maybe NgramsTerm))] -> [(a, [a])])
-> [(NgramsTerm, (ListType, Maybe NgramsTerm))]
-> HashMap a [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((NgramsTerm, (ListType, Maybe NgramsTerm)) -> (a, [a]))
-> [(NgramsTerm, (ListType, Maybe NgramsTerm))] -> [(a, [a])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (NgramsTerm, (ListType, Maybe NgramsTerm)) -> (a, [a])
toTreeWith
                      ([(NgramsTerm, (ListType, Maybe NgramsTerm))] -> HashMap a [a])
-> (HashMap NgramsTerm (ListType, Maybe NgramsTerm)
    -> [(NgramsTerm, (ListType, Maybe NgramsTerm))])
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap a [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> [(NgramsTerm, (ListType, Maybe NgramsTerm))]
forall k v. HashMap k v -> [(k, v)]
HM.toList
                      (HashMap NgramsTerm (ListType, Maybe NgramsTerm) -> HashMap a [a])
-> (HashMap NgramsTerm (ListType, Maybe NgramsTerm)
    -> HashMap NgramsTerm (ListType, Maybe NgramsTerm))
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap a [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ListType, Maybe NgramsTerm) -> Bool)
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HM.filter (\(ListType, Maybe NgramsTerm)
f' -> ListType -> Set ListType -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ((ListType, Maybe NgramsTerm) -> ListType
forall a b. (a, b) -> a
fst (ListType, Maybe NgramsTerm)
f') Set ListType
lts)
                      (HashMap NgramsTerm (ListType, Maybe NgramsTerm) -> HashMap a [a])
-> (NodeListStory
    -> HashMap NgramsTerm (ListType, Maybe NgramsTerm))
-> NodeListStory
-> HashMap a [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ListId]
-> NgramsType
-> NodeListStory
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
mapTermListRoot [ListId]
ls NgramsType
ngt
                      (NodeListStory -> HashMap a [a])
-> m NodeListStory -> m (HashMap a [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ListId] -> m NodeListStory
forall env err (m :: * -> *).
HasNodeStory env err m =>
[ListId] -> m NodeListStory
getRepo' [ListId]
ls
  where
    toTreeWith :: (NgramsTerm, (ListType, Maybe NgramsTerm)) -> (a, [a])
toTreeWith (NgramsTerm
t, (ListType
_lt, Maybe NgramsTerm
maybeRoot)) = case Maybe NgramsTerm
maybeRoot of
      Maybe NgramsTerm
Nothing -> (NgramsTerm -> a
f NgramsTerm
t, [])
      Just  NgramsTerm
r -> (NgramsTerm -> a
f NgramsTerm
r, [NgramsTerm -> a
f NgramsTerm
t])



mapTermListRoot :: [ListId]
                -> NgramsType
                -> NodeListStory
                -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
mapTermListRoot :: [ListId]
-> NgramsType
-> NodeListStory
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
mapTermListRoot [ListId]
nodeIds NgramsType
ngramsType NodeListStory
repo =
      (\NgramsRepoElement
nre -> (NgramsRepoElement -> ListType
_nre_list NgramsRepoElement
nre, NgramsRepoElement -> Maybe NgramsTerm
_nre_root NgramsRepoElement
nre))
  (NgramsRepoElement -> (ListType, Maybe NgramsTerm))
-> HashMap NgramsTerm NgramsRepoElement
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ListId]
-> NgramsType
-> NodeListStory
-> HashMap NgramsTerm NgramsRepoElement
listNgramsFromRepo [ListId]
nodeIds NgramsType
ngramsType NodeListStory
repo




filterListWithRootHashMap :: ListType
                          -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
                          -> HashMap NgramsTerm (Maybe RootTerm)
filterListWithRootHashMap :: ListType
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (Maybe NgramsTerm)
filterListWithRootHashMap ListType
lt HashMap NgramsTerm (ListType, Maybe NgramsTerm)
m = (ListType, Maybe NgramsTerm) -> Maybe NgramsTerm
forall a b. (a, b) -> b
snd ((ListType, Maybe NgramsTerm) -> Maybe NgramsTerm)
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (Maybe NgramsTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ListType, Maybe NgramsTerm) -> Bool)
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HM.filter (ListType, Maybe NgramsTerm) -> Bool
isMapTerm HashMap NgramsTerm (ListType, Maybe NgramsTerm)
m
  where
    isMapTerm :: (ListType, Maybe NgramsTerm) -> Bool
isMapTerm (ListType
l, Maybe NgramsTerm
maybeRoot) = case Maybe NgramsTerm
maybeRoot of
      Maybe NgramsTerm
Nothing -> ListType
l ListType -> ListType -> Bool
forall a. Eq a => a -> a -> Bool
== ListType
lt
      Just  NgramsTerm
r -> case NgramsTerm
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> Maybe (ListType, Maybe NgramsTerm)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup NgramsTerm
r HashMap NgramsTerm (ListType, Maybe NgramsTerm)
m of
        Maybe (ListType, Maybe NgramsTerm)
Nothing -> Text -> Bool
forall a. HasCallStack => Text -> a
panic (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text
"[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NgramsTerm -> Text
unNgramsTerm NgramsTerm
r
        Just  (ListType
l',Maybe NgramsTerm
_) -> ListType
l' ListType -> ListType -> Bool
forall a. Eq a => a -> a -> Bool
== ListType
lt

filterListWithRoot :: ListType
                   -> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
                   -> HashMap NgramsTerm (Maybe RootTerm)
filterListWithRoot :: ListType
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (Maybe NgramsTerm)
filterListWithRoot ListType
lt HashMap NgramsTerm (ListType, Maybe NgramsTerm)
m = (ListType, Maybe NgramsTerm) -> Maybe NgramsTerm
forall a b. (a, b) -> b
snd ((ListType, Maybe NgramsTerm) -> Maybe NgramsTerm)
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (Maybe NgramsTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((ListType, Maybe NgramsTerm) -> Bool)
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HM.filter (ListType, Maybe NgramsTerm) -> Bool
isMapTerm HashMap NgramsTerm (ListType, Maybe NgramsTerm)
m
  where
    isMapTerm :: (ListType, Maybe NgramsTerm) -> Bool
isMapTerm (ListType
l, Maybe NgramsTerm
maybeRoot) = case Maybe NgramsTerm
maybeRoot of
      Maybe NgramsTerm
Nothing -> ListType
l ListType -> ListType -> Bool
forall a. Eq a => a -> a -> Bool
== ListType
lt
      Just  NgramsTerm
r -> case NgramsTerm
-> HashMap NgramsTerm (ListType, Maybe NgramsTerm)
-> Maybe (ListType, Maybe NgramsTerm)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup NgramsTerm
r HashMap NgramsTerm (ListType, Maybe NgramsTerm)
m of
        Maybe (ListType, Maybe NgramsTerm)
Nothing -> Text -> Bool
forall a. HasCallStack => Text -> a
panic (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text
"[Garg.API.Ngrams.Tools] filterWithRoot, unknown key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NgramsTerm -> Text
unNgramsTerm NgramsTerm
r
        Just  (ListType
l',Maybe NgramsTerm
_) -> ListType
l' ListType -> ListType -> Bool
forall a. Eq a => a -> a -> Bool
== ListType
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 :: root_map
-> HashMap NgramsTerm (Set ListId)
-> HashMap NgramsTerm (Set ListId)
groupNodesByNgrams root_map
syn HashMap NgramsTerm (Set ListId)
occs = (Set ListId -> Set ListId -> Set ListId)
-> [(NgramsTerm, Set ListId)] -> HashMap NgramsTerm (Set ListId)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HM.fromListWith Set ListId -> Set ListId -> Set ListId
forall a. Semigroup a => a -> a -> a
(<>) [(NgramsTerm, Set ListId)]
occs'
  where
    occs' :: [(NgramsTerm, Set ListId)]
occs' = ((NgramsTerm, Set ListId) -> (NgramsTerm, Set ListId))
-> [(NgramsTerm, Set ListId)] -> [(NgramsTerm, Set ListId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (NgramsTerm, Set ListId) -> (NgramsTerm, Set ListId)
toSyn (HashMap NgramsTerm (Set ListId) -> [(NgramsTerm, Set ListId)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap NgramsTerm (Set ListId)
occs)
    toSyn :: (NgramsTerm, Set ListId) -> (NgramsTerm, Set ListId)
toSyn (NgramsTerm
t,Set ListId
ns) = case root_map
syn root_map
-> Getting
     (Maybe (Maybe NgramsTerm)) root_map (Maybe (Maybe NgramsTerm))
-> Maybe (Maybe NgramsTerm)
forall s a. s -> Getting a s a -> a
^. Index root_map -> Lens' root_map (Maybe (IxValue root_map))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index root_map
NgramsTerm
t of
      Maybe (Maybe NgramsTerm)
Nothing -> Text -> (NgramsTerm, Set ListId)
forall a. HasCallStack => Text -> a
panic (Text -> (NgramsTerm, Set ListId))
-> Text -> (NgramsTerm, Set ListId)
forall a b. (a -> b) -> a -> b
$ Text
"[Garg.API.Ngrams.Tools.groupNodesByNgrams] unknown key: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NgramsTerm -> Text
unNgramsTerm NgramsTerm
t
      Just  Maybe NgramsTerm
r -> case Maybe NgramsTerm
r of
        Maybe NgramsTerm
Nothing  -> (NgramsTerm
t, Set ListId
ns)
        Just  NgramsTerm
r' -> (NgramsTerm
r',Set ListId
ns)

data Diagonal = Diagonal Bool

getCoocByNgrams :: Diagonal
                -> HashMap NgramsTerm (Set NodeId)
                -> HashMap (NgramsTerm, NgramsTerm) Int
getCoocByNgrams :: Diagonal
-> HashMap NgramsTerm (Set ListId)
-> HashMap (NgramsTerm, NgramsTerm) Int
getCoocByNgrams = (Set ListId -> Set ListId)
-> Diagonal
-> HashMap NgramsTerm (Set ListId)
-> HashMap (NgramsTerm, NgramsTerm) Int
forall a c b.
(Hashable a, Ord a, Ord c) =>
(b -> Set c) -> Diagonal -> HashMap a b -> HashMap (a, a) Int
getCoocByNgrams' Set ListId -> Set ListId
forall a. a -> a
identity


getCoocByNgrams' :: (Hashable a, Ord a, Ord c)
                 => (b -> Set c)
                 -> Diagonal
                 -> HashMap a b
                 -> HashMap (a, a) Int
getCoocByNgrams' :: (b -> Set c) -> Diagonal -> HashMap a b -> HashMap (a, a) Int
getCoocByNgrams' b -> Set c
f (Diagonal Bool
diag) HashMap a b
m =
  [((a, a), Int)] -> HashMap (a, a) Int
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [( (a
t1,a
t2)
               , Int -> (Set c -> Int) -> Maybe (Set c) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Set c -> Int
forall a. Set a -> Int
Set.size (Maybe (Set c) -> Int) -> Maybe (Set c) -> Int
forall a b. (a -> b) -> a -> b
$ Set c -> Set c -> Set c
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection
                                 (Set c -> Set c -> Set c)
-> Maybe (Set c) -> Maybe (Set c -> Set c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((b -> Set c) -> Maybe b -> Maybe (Set c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Set c
f (Maybe b -> Maybe (Set c)) -> Maybe b -> Maybe (Set c)
forall a b. (a -> b) -> a -> b
$ a -> HashMap a b -> Maybe b
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup a
t1 HashMap a b
m)
                                 Maybe (Set c -> Set c) -> Maybe (Set c) -> Maybe (Set c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((b -> Set c) -> Maybe b -> Maybe (Set c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Set c
f (Maybe b -> Maybe (Set c)) -> Maybe b -> Maybe (Set c)
forall a b. (a -> b) -> a -> b
$ a -> HashMap a b -> Maybe b
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup a
t2 HashMap a b
m)
               )
              | (a
t1,a
t2) <- if Bool
diag then
                             [ (a
x,a
y) | a
x <- [a]
ks, a
y <- [a]
ks, a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y] -- TODO if we keep a Data.Map here it might be
                                                                 -- more efficient to enumerate all the y <= x.
                           else
                             (a -> a) -> [a] -> [(a, a)]
forall a b. (a -> b) -> [a] -> [(b, b)]
listToCombi a -> a
forall a. a -> a
identity [a]
ks
              ]

  where ks :: [a]
ks = HashMap a b -> [a]
forall k v. HashMap k v -> [k]
HM.keys HashMap a b
m

------------------------------------------