src/Gargantext/Core/Text/List/Social.hs

   1 {-|
   2 Module      : Gargantext.Core.Text.List.Social
   3 Description :
   4 Copyright   : (c) CNRS, 2018-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10
  11 -}
  12
  13 module Gargantext.Core.Text.List.Social
  14   where
  15
  16 -- findList imports
  17 import Gargantext.Core.Types.Individu
  18 import Gargantext.Database.Admin.Config
  19 import Gargantext.Database.Admin.Types.Node
  20 import Gargantext.Database.Prelude
  21 import Gargantext.Database.Query.Table.Node.Error
  22 import Gargantext.Database.Query.Tree
  23 import Gargantext.Database.Query.Tree.Root (getRootId)
  24 import Gargantext.Prelude
  25
  26 -- filterList imports
  27 import Data.Map (Map)
  28 import Data.Set (Set)
  29 import Data.Text (Text)
  30 import Gargantext.API.Ngrams
  31 import Gargantext.API.Ngrams.Tools -- (getListNgrams)
  32 import Gargantext.API.Ngrams.Types
  33 import Gargantext.Core.Types.Main
  34 import Gargantext.Database.Schema.Ngrams
  35 import qualified Data.List as List
  36 import qualified Data.Map as Map
  37 import qualified Data.Set as Set
  38
  39
  40 {-
  41 flowSocialList :: ( RepoCmdM env err m
  42                         , CmdM     env err m
  43                         , HasNodeError err
  44                         , HasTreeError err
  45                         )
  46                      => NodeMode -> User -> NgramsType -> Set Text
  47                      -> m (Map (Maybe ListType) (Set Text))
  48 flowSocialList mode user nt ngrams' = do
  49   privateMapList <- flowSocialListByMode Private user nt ngrams'
  50   sharedMapList  <- flowSocialListByMode Shared  user nt (fromMaybe Set.empty $
  51   -- TODO publicMapList
  52 -}
  53
  54 flowSocialListByMode :: ( RepoCmdM env err m
  55                         , CmdM     env err m
  56                         , HasNodeError err
  57                         , HasTreeError err
  58                         )
  59                      => NodeMode -> User -> NgramsType -> Set Text
  60                      -> m (Map (Maybe ListType) (Set Text))
  61 flowSocialListByMode mode user nt ngrams' = do
  62   listIds <- findListsId mode user
  63   counts  <- countFilterList ngrams' nt listIds Map.empty
  64   pure $ toSocialList counts ngrams'
  65
  66 ---------------------------------------------------------------------------
  67 -- TODO: maybe use social groups too
  68 toSocialList :: Map Text (Map ListType Int)
  69              -> Set Text
  70              -> Map (Maybe ListType) (Set Text)
  71 toSocialList m = Map.fromListWith (<>)
  72                . Set.toList
  73                . Set.map (toSocialList1 m)
  74
  75 -- | TODO what if equality ?
  76 -- choice depends on Ord instance of ListType
  77 -- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
  78 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
  79 -- (we minimize errors on MapTerms if doubt)
  80 toSocialList1 :: Map Text (Map ListType Int)
  81              -> Text
  82              -> (Maybe ListType, Set Text)
  83 toSocialList1 m t = case Map.lookup t m of
  84   Nothing -> (Nothing, Set.singleton t)
  85   Just  m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
  86               , Set.singleton t
  87               )
  88
  89 ---------------------------------------------------------------------------
  90 -- | [ListId] does not merge the lists (it is for Master and User lists
  91 -- here we need UserList only
  92 countFilterList :: RepoCmdM env err m
  93         => Set Text -> NgramsType -> [ListId]
  94         -> Map Text (Map ListType Int)
  95         -> m (Map Text (Map ListType Int))
  96 countFilterList st nt ls input =
  97   foldM' (\m l -> countFilterList' st nt [l] m) input ls
  98
  99
 100 countFilterList' :: RepoCmdM env err m
 101         => Set Text -> NgramsType -> [ListId]
 102         -> Map Text (Map ListType Int)
 103         -> m (Map Text (Map ListType Int))
 104 countFilterList' st nt ls input = do
 105   ml <- toMapTextListType <$> getListNgrams ls nt
 106   pure $ Set.foldl' (\m t -> countList t ml m) input st
 107
 108 ---------------------------------------------------------------------------
 109 toMapTextListType :: Map Text NgramsRepoElement -> Map Text ListType
 110 toMapTextListType = Map.fromListWith (<>)
 111               . List.concat
 112               . (map toList)
 113               . Map.toList
 114
 115 toList :: (Text, NgramsRepoElement) -> [(Text, ListType)]
 116 toList (t, NgramsRepoElement _ lt root parent (MSet children)) =
 117      List.zip terms (List.cycle [lt])
 118       where
 119         terms =  [t]
 120               <> maybe [] (\n -> [unNgramsTerm n]) root
 121               <> maybe [] (\n -> [unNgramsTerm n]) parent
 122               <> (map unNgramsTerm $ Map.keys children)
 123
 124 ---------------------------------------------------------------------------
 125 countList :: Text
 126           -> Map Text ListType
 127           -> Map Text (Map ListType Int)
 128           -> Map Text (Map ListType Int)
 129 countList t m input = case Map.lookup t m of
 130   Nothing -> input
 131   Just l  -> Map.alter addList t input
 132     where
 133       addList Nothing   = Just $ addCount l Map.empty
 134       addList (Just lm) = Just $ addCount l lm
 135
 136 addCount :: ListType -> Map ListType Int -> Map ListType Int
 137 addCount l m = Map.alter plus l  m
 138   where
 139     plus Nothing  = Just 1
 140     plus (Just x) = Just $ x + 1
 141
 142 ------------------------------------------------------------------------
 143 findListsId :: (HasNodeError err, HasTreeError err)
 144             => NodeMode -> User -> Cmd err [NodeId]
 145 findListsId mode u = do
 146   r <- getRootId u
 147   map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
 148                  <$> findNodes' mode r
 149
 150 findNodes' :: HasTreeError err
 151           => NodeMode -> RootId
 152           -> Cmd err [DbTreeNode]
 153 findNodes' Private r = findNodes Private r [NodeFolderPrivate, NodeCorpus, NodeList]
 154 findNodes' Shared  r = findNodes Shared  r [NodeFolderShared , NodeCorpus, NodeList]
 155 findNodes' Public  r = findNodes Public  r [NodeFolderPublic , NodeCorpus, NodeList]