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 module Gargantext.Core.Text.List.Social
  12   where
  13
  14 -- findList imports
  15 import Gargantext.Core.Types.Individu
  16 import Gargantext.Database.Admin.Config
  17 import Gargantext.Database.Admin.Types.Node
  18 import Gargantext.Database.Prelude
  19 import Gargantext.Database.Query.Table.Node.Error
  20 import Gargantext.Database.Query.Tree
  21 import Gargantext.Database.Query.Tree.Root (getRootId)
  22 import Gargantext.Prelude
  23
  24 -- filterList imports
  25 import Data.Maybe (fromMaybe)
  26 import Data.Map (Map)
  27 import Data.Set (Set)
  28 import Data.Text (Text)
  29 import Gargantext.API.Ngrams.Tools -- (getListNgrams)
  30 import Gargantext.API.Ngrams.Types
  31 import Gargantext.Core.Types.Main
  32 import Gargantext.Database.Schema.Ngrams
  33 import qualified Data.List as List
  34 import qualified Data.Map as Map
  35 import qualified Data.Set as Set
  36
  37
  38 flowSocialList :: ( RepoCmdM env err m
  39                   , CmdM     env err m
  40                   , HasNodeError err
  41                   , HasTreeError err
  42                   )
  43                   => User -> NgramsType -> Set Text
  44                   -> m (Map ListType (Set Text))
  45 flowSocialList user nt ngrams' = do
  46   privateLists <- flowSocialListByMode Private user nt ngrams'
  47   printDebug "* privateLists *: \n" privateLists
  48   sharedLists  <- flowSocialListByMode Shared  user nt (termsByList CandidateTerm privateLists)
  49   printDebug "* socialLists *: \n" sharedLists
  50    -- TODO publicMapList
  51
  52   pure $ Map.fromList [ (MapTerm, termsByList MapTerm privateLists
  53                                <> termsByList MapTerm sharedLists
  54                         )
  55                       , (StopTerm, termsByList StopTerm privateLists
  56                                 <> termsByList StopTerm sharedLists
  57                         )
  58                       , (CandidateTerm, termsByList CandidateTerm sharedLists)
  59                       ]
  60
  61
  62 termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
  63 termsByList CandidateTerm m = Set.unions
  64                           $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
  65                           [ Nothing, Just CandidateTerm ]
  66 termsByList l m =
  67   fromMaybe Set.empty $ Map.lookup (Just l) m
  68
  69
  70
  71 flowSocialListByMode :: ( RepoCmdM env err m
  72                         , CmdM     env err m
  73                         , HasNodeError err
  74                         , HasTreeError err
  75                         )
  76                      => NodeMode -> User -> NgramsType -> Set Text
  77                      -> m (Map (Maybe ListType) (Set Text))
  78 flowSocialListByMode mode user nt ngrams' = do
  79   listIds <- findListsId mode user
  80   case listIds of
  81     [] -> pure $ Map.fromList [(Nothing, ngrams')]
  82     _  -> do
  83       counts  <- countFilterList ngrams' nt listIds Map.empty
  84       printDebug "flowSocialListByMode counts" counts
  85       pure     $ toSocialList counts ngrams'
  86
  87 ---------------------------------------------------------------------------
  88 -- TODO: maybe use social groups too
  89 toSocialList :: Map Text (Map ListType Int)
  90              -> Set Text
  91              -> Map (Maybe ListType) (Set Text)
  92 toSocialList m = Map.fromListWith (<>)
  93                . Set.toList
  94                . Set.map (toSocialList1 m)
  95
  96 -- | TODO what if equality ?
  97 -- choice depends on Ord instance of ListType
  98 -- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
  99 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
 100 -- (we minimize errors on MapTerms if doubt)
 101 toSocialList1 :: Map Text (Map ListType Int)
 102              -> Text
 103              -> (Maybe ListType, Set Text)
 104 toSocialList1 m t = case Map.lookup t m of
 105   Nothing -> (Nothing, Set.singleton t)
 106   Just  m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
 107               , Set.singleton t
 108               )
 109
 110 ---------------------------------------------------------------------------
 111 -- | [ListId] does not merge the lists (it is for Master and User lists
 112 -- here we need UserList only
 113 countFilterList :: RepoCmdM env err m
 114         => Set Text -> NgramsType -> [ListId]
 115         -> Map Text (Map ListType Int)
 116         -> m (Map Text (Map ListType Int))
 117 countFilterList st nt ls input =
 118   foldM' (\m l -> countFilterList' st nt [l] m) input ls
 119
 120
 121 countFilterList' :: RepoCmdM env err m
 122         => Set Text -> NgramsType -> [ListId]
 123         -> Map Text (Map ListType Int)
 124         -> m (Map Text (Map ListType Int))
 125 countFilterList' st nt ls input = do
 126   ml <- toMapTextListType <$> getListNgrams ls nt
 127   printDebug "countFilterList'" ml
 128   pure $ Set.foldl' (\m t -> countList t ml m) input st
 129
 130 ---------------------------------------------------------------------------
 131 -- FIXME children have to herit the ListType of the parent
 132 toMapTextListType :: Map Text NgramsRepoElement -> Map Text ListType
 133 toMapTextListType m = Map.fromListWith (<>)
 134               $ List.concat
 135               $ (map (toList m))
 136               $ Map.toList m
 137
 138 listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
 139 listOf m ng = case _nre_parent ng of
 140   Nothing -> _nre_list ng
 141   Just  p -> case Map.lookup (unNgramsTerm p) m of
 142     Nothing  -> CandidateTerm -- Should Not happen
 143     Just ng' -> listOf m ng'
 144
 145 toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
 146 toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
 147      List.zip terms (List.cycle [lt'])
 148       where
 149         terms =  [t]
 150               -- <> maybe [] (\n -> [unNgramsTerm n]) root
 151               -- <> maybe [] (\n -> [unNgramsTerm n]) parent
 152               <> (map unNgramsTerm $ Map.keys children)
 153         lt'   = listOf m nre
 154
 155 ---------------------------------------------------------------------------
 156 countList :: Text
 157           -> Map Text ListType
 158           -> Map Text (Map ListType Int)
 159           -> Map Text (Map ListType Int)
 160 countList t m input = case Map.lookup t m of
 161   Nothing -> input
 162   Just l  -> Map.alter addList t input
 163     where
 164       addList Nothing   = Just $ addCount l Map.empty
 165       addList (Just lm) = Just $ addCount l lm
 166
 167 addCount :: ListType -> Map ListType Int -> Map ListType Int
 168 addCount l m = Map.alter plus l  m
 169   where
 170     plus Nothing  = Just 1
 171     plus (Just x) = Just $ x + 1
 172
 173 ------------------------------------------------------------------------
 174 findListsId :: (HasNodeError err, HasTreeError err)
 175             => NodeMode -> User -> Cmd err [NodeId]
 176 findListsId mode u = do
 177   r <- getRootId u
 178   ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
 179                        <$> findNodes' mode r
 180   printDebug "findListsIds" ns
 181   pure ns
 182
 183 commonNodes:: [NodeType]
 184 commonNodes = [NodeFolder, NodeCorpus, NodeList]
 185
 186 findNodes' :: HasTreeError err
 187           => NodeMode -> RootId
 188           -> Cmd err [DbTreeNode]
 189 findNodes' Private r = findNodes Private r $ [NodeFolderPrivate] <> commonNodes
 190 findNodes' Shared  r = findNodes Shared  r $ [NodeFolderShared ] <> commonNodes
 191 findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes