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.Semigroup (Semigroup(..))
  29 import Data.Text (Text)
  30 import Gargantext.API.Ngrams.Tools -- (getListNgrams)
  31 import Gargantext.API.Ngrams.Types
  32 import Gargantext.Core.Types.Main
  33 import Gargantext.Database.Schema.Ngrams
  34 import qualified Data.List  as List
  35 import qualified Data.Map   as Map
  36 import qualified Data.Set   as Set
  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   -- here preference to privateLists (discutable)
  49   sharedLists  <- flowSocialListByMode Shared  user nt (termsByList CandidateTerm privateLists)
  50   printDebug "* sharedLists *: \n" sharedLists
  51    -- TODO publicMapList
  52
  53   let result = unions [ Map.mapKeys (fromMaybe CandidateTerm) privateLists
  54                 , Map.mapKeys (fromMaybe CandidateTerm) sharedLists
  55                 ]
  56   printDebug "* socialLists *: results \n" sharedLists
  57   pure result
  58
  59
  60 ------------------------------------------------------------------------
  61 unions :: (Ord a, Semigroup a, Semigroup b, Ord b)
  62       => [Map a (Set b)] -> Map a (Set b)
  63 unions = foldl' union Map.empty
  64
  65 union :: (Ord a, Semigroup a, Semigroup b, Ord b)
  66       => Map a (Set b) -> Map a (Set b) -> Map a (Set b)
  67 union m1 m2 = invertBack $ Map.unionWith (<>) (invert m1) (invert m2)
  68
  69 invert :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
  70 invert = Map.unionsWith (<>)
  71        . (map (\(k,ss) -> Map.fromSet (\_ -> k) ss))
  72        . Map.toList
  73
  74 invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
  75 invertBack = Map.fromListWith (<>)
  76            . (map (\(b,a) -> (a, Set.singleton b)))
  77            .  Map.toList
  78
  79 ------------------------------------------------------------------------
  80
  81 termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
  82 termsByList CandidateTerm m = Set.unions
  83                           $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
  84                           [ Nothing, Just CandidateTerm ]
  85 termsByList l m =
  86   fromMaybe Set.empty $ Map.lookup (Just l) m
  87
  88
  89 flowSocialListByMode :: ( RepoCmdM env err m
  90                         , CmdM     env err m
  91                         , HasNodeError err
  92                         , HasTreeError err
  93                         )
  94                      => NodeMode -> User -> NgramsType -> Set Text
  95                      -> m (Map (Maybe ListType) (Set Text))
  96 flowSocialListByMode mode user nt ngrams' = do
  97   listIds <- findListsId mode user
  98   case listIds of
  99     [] -> pure $ Map.fromList [(Nothing, ngrams')]
 100     _  -> do
 101       counts  <- countFilterList ngrams' nt listIds Map.empty
 102       printDebug "flowSocialListByMode counts" counts
 103       let r = toSocialList counts ngrams'
 104       printDebug "flowSocialListByMode r" r
 105       pure r
 106
 107 ---------------------------------------------------------------------------
 108 -- TODO: maybe use social groups too
 109 toSocialList :: Map Text (Map ListType Int)
 110              -> Set Text
 111              -> Map (Maybe ListType) (Set Text)
 112 toSocialList m = Map.fromListWith (<>)
 113                . Set.toList
 114                . Set.map (toSocialList1 m)
 115
 116 -- | TODO what if equality ?
 117 -- choice depends on Ord instance of ListType
 118 -- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
 119 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
 120 -- (we minimize errors on MapTerms if doubt)
 121 toSocialList1 :: Map Text (Map ListType Int)
 122              -> Text
 123              -> (Maybe ListType, Set Text)
 124 toSocialList1 m t = case Map.lookup t m of
 125   Nothing -> (Nothing, Set.singleton t)
 126   Just  m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
 127               , Set.singleton t
 128               )
 129
 130 toSocialList1_testIsTrue :: Bool
 131 toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
 132   where
 133     result = toSocialList1 (Map.fromList [(token, m)]) token
 134     token  = "token"
 135     m = Map.fromList [ (CandidateTerm, 1)
 136                      , (MapTerm      , 2)
 137                      , (StopTerm     , 3)
 138                      ]
 139
 140 ---------------------------------------------------------------------------
 141 -- | [ListId] does not merge the lists (it is for Master and User lists
 142 -- here we need UserList only
 143 countFilterList :: RepoCmdM env err m
 144         => Set Text -> NgramsType -> [ListId]
 145         -> Map Text (Map ListType Int)
 146         -> m (Map Text (Map ListType Int))
 147 countFilterList st nt ls input =
 148   foldM' (\m l -> countFilterList' st nt [l] m) input ls
 149
 150
 151 countFilterList' :: RepoCmdM env err m
 152         => Set Text -> NgramsType -> [ListId]
 153         -> Map Text (Map ListType Int)
 154         -> m (Map Text (Map ListType Int))
 155 countFilterList' st nt ls input = do
 156   ml <- toMapTextListType <$> getListNgrams ls nt
 157   -- printDebug "countFilterList'" ml
 158   pure $ Set.foldl' (\m t -> countList t ml m) input st
 159
 160 ---------------------------------------------------------------------------
 161 -- FIXME children have to herit the ListType of the parent
 162 toMapTextListType :: Map Text NgramsRepoElement -> Map Text ListType
 163 toMapTextListType m = Map.fromListWith (<>)
 164                     $  List.concat
 165                     $ (map (toList m))
 166                     $  Map.toList m
 167
 168 toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
 169 toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
 170      List.zip terms (List.cycle [lt'])
 171       where
 172         terms =  [t]
 173               -- <> maybe [] (\n -> [unNgramsTerm n]) root
 174               -- <> maybe [] (\n -> [unNgramsTerm n]) parent
 175               <> (map unNgramsTerm $ Map.keys children)
 176         lt'   = listOf m nre
 177
 178 listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
 179 listOf m ng = case _nre_parent ng of
 180   Nothing -> _nre_list ng
 181   Just  p -> case Map.lookup (unNgramsTerm p) m of
 182     Just ng' -> listOf m ng'
 183     Nothing  -> CandidateTerm -- Should Not happen
 184
 185 ---------------------------------------------------------------------------
 186 countList :: Text
 187           -> Map Text ListType
 188           -> Map Text (Map ListType Int)
 189           -> Map Text (Map ListType Int)
 190 countList t m input = case Map.lookup t m of
 191   Nothing -> input
 192   Just l  -> Map.alter addList t input
 193     where
 194       addList Nothing   = Just $ addCount l Map.empty
 195       addList (Just lm) = Just $ addCount l lm
 196
 197 addCount :: ListType -> Map ListType Int -> Map ListType Int
 198 addCount l m = Map.alter plus l  m
 199   where
 200     plus Nothing  = Just 1
 201     plus (Just x) = Just $ x + 1
 202
 203 ------------------------------------------------------------------------
 204 findListsId :: (HasNodeError err, HasTreeError err)
 205             => NodeMode -> User -> Cmd err [NodeId]
 206 findListsId mode u = do
 207   r <- getRootId u
 208   ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
 209                        <$> findNodes' mode r
 210   -- printDebug "findListsIds" ns
 211   pure ns
 212
 213 commonNodes:: [NodeType]
 214 commonNodes = [NodeFolder, NodeCorpus, NodeList]
 215
 216 findNodes' :: HasTreeError err
 217           => NodeMode -> RootId
 218           -> Cmd err [DbTreeNode]
 219 findNodes' Private r = findNodes Private r $ [NodeFolderPrivate] <> commonNodes
 220 findNodes' Shared  r = findNodes Shared  r $ [NodeFolderShared ] <> commonNodes
 221 findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes