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 ------------------------------------------------------------------------
  39 flowSocialList :: ( RepoCmdM env err m
  40                   , CmdM     env err m
  41                   , HasNodeError err
  42                   , HasTreeError err
  43                   )
  44                   => User -> NgramsType -> Set Text
  45                   -> m (Map ListType (Set Text))
  46 flowSocialList user nt ngrams' = do
  47   privateLists <- flowSocialListByMode Private user nt ngrams'
  48   -- printDebug "* privateLists *: \n" privateLists
  49   -- here preference to privateLists (discutable)
  50   sharedLists  <- flowSocialListByMode Shared  user nt (termsByList CandidateTerm privateLists)
  51   -- printDebug "* sharedLists *: \n" sharedLists
  52    -- TODO publicMapList
  53
  54   let result = unions [ Map.mapKeys (fromMaybe CandidateTerm) privateLists
  55                       , Map.mapKeys (fromMaybe CandidateTerm) sharedLists
  56                       ]
  57   -- printDebug "* socialLists *: results \n" result
  58   pure result
  59
  60
  61 ------------------------------------------------------------------------
  62 unions :: (Ord a, Semigroup a, Semigroup b, Ord b)
  63       => [Map a (Set b)] -> Map a (Set b)
  64 unions = invertBack . Map.unionsWith (<>) . map invertForw
  65
  66 invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
  67 invertForw = Map.unionsWith (<>)
  68            . (map (\(k,sets) -> Map.fromSet (\_ -> k) sets))
  69            . Map.toList
  70
  71 invertBack :: (Ord a, Ord b) => Map b a -> Map a (Set b)
  72 invertBack = Map.fromListWith (<>)
  73            . (map (\(b,a) -> (a, Set.singleton b)))
  74            .  Map.toList
  75
  76 unions_test :: Map ListType (Set Text)
  77 unions_test = unions [m1, m2]
  78   where
  79     m1 = Map.fromList [ (StopTerm, Set.singleton "Candidate")]
  80     m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")
  81                       , (MapTerm, Set.singleton "Candidate")
  82                       ]
  83
  84 ------------------------------------------------------------------------
  85
  86 termsByList :: ListType -> (Map (Maybe ListType) (Set Text)) -> Set Text
  87 termsByList CandidateTerm m = Set.unions
  88                           $ map (\lt -> fromMaybe Set.empty $ Map.lookup lt m)
  89                           [ Nothing, Just CandidateTerm ]
  90 termsByList l m =
  91   fromMaybe Set.empty $ Map.lookup (Just l) m
  92
  93
  94 flowSocialListByMode :: ( RepoCmdM env err m
  95                         , CmdM     env err m
  96                         , HasNodeError err
  97                         , HasTreeError err
  98                         )
  99                      => NodeMode -> User -> NgramsType -> Set Text
 100                      -> m (Map (Maybe ListType) (Set Text))
 101 flowSocialListByMode mode user nt ngrams' = do
 102   listIds <- findListsId mode user
 103   case listIds of
 104     [] -> pure $ Map.fromList [(Nothing, ngrams')]
 105     _  -> do
 106       counts  <- countFilterList ngrams' nt listIds Map.empty
 107       -- printDebug "flowSocialListByMode counts" counts
 108       let r = toSocialList counts ngrams'
 109       -- printDebug "flowSocialListByMode r" r
 110       pure r
 111
 112 ------------------------------------------------------------------------
 113 -- TODO: maybe use social groups too
 114 toSocialList :: Map Text (Map ListType Int)
 115              -> Set Text
 116              -> Map (Maybe ListType) (Set Text)
 117 toSocialList m = Map.fromListWith (<>)
 118                . Set.toList
 119                . Set.map (toSocialList1 m)
 120
 121 -- | TODO what if equality ?
 122 -- choice depends on Ord instance of ListType
 123 -- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
 124 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
 125 -- (we minimize errors on MapTerms if doubt)
 126 toSocialList1 :: Map Text (Map ListType Int)
 127              -> Text
 128              -> (Maybe ListType, Set Text)
 129 toSocialList1 m t = case Map.lookup t m of
 130   Nothing -> (Nothing, Set.singleton t)
 131   Just  m' -> ( (fst . fst) <$> Map.maxViewWithKey m'
 132               , Set.singleton t
 133               )
 134
 135 toSocialList1_testIsTrue :: Bool
 136 toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
 137   where
 138     result = toSocialList1 (Map.fromList [(token, m)]) token
 139     token  = "token"
 140     m = Map.fromList [ (CandidateTerm, 1)
 141                      , (MapTerm      , 2)
 142                      , (StopTerm     , 3)
 143                      ]
 144
 145 ------------------------------------------------------------------------
 146 -- | [ListId] does not merge the lists (it is for Master and User lists
 147 -- here we need UserList only
 148 countFilterList :: RepoCmdM env err m
 149         => Set Text -> NgramsType -> [ListId]
 150         -> Map Text (Map ListType Int)
 151         -> m (Map Text (Map ListType Int))
 152 countFilterList st nt ls input =
 153   foldM' (\m l -> countFilterList' st nt [l] m) input ls
 154
 155
 156 countFilterList' :: RepoCmdM env err m
 157         => Set Text -> NgramsType -> [ListId]
 158         -> Map Text (Map ListType Int)
 159         -> m (Map Text (Map ListType Int))
 160 countFilterList' st nt ls input = do
 161   ml <- toMapTextListType <$> getListNgrams ls nt
 162   -- printDebug "countFilterList'" ml
 163   pure $ Set.foldl' (\m t -> countList t ml m) input st
 164
 165 ------------------------------------------------------------------------
 166 -- FIXME children have to herit the ListType of the parent
 167 toMapTextListType :: Map Text NgramsRepoElement -> Map Text ListType
 168 toMapTextListType m = Map.fromListWith (<>)
 169                     $ List.concat
 170                     $ map (toList m)
 171                     $ Map.toList m
 172
 173 ----------------------
 174 type Parent = Text
 175
 176 hasParent :: Text
 177           -> Map Text (Map Parent Int)
 178           -> Maybe Parent
 179 hasParent t m = case Map.lookup t m of
 180   Nothing  -> Nothing
 181   Just  m' -> (fst . fst) <$> Map.maxViewWithKey m'
 182
 183
 184 toMapTextParent :: Set Text
 185                 ->  Map Text (Map Parent Int)
 186                 -> [Map Text NgramsRepoElement]
 187                 -> Map Text (Map Parent Int)
 188 toMapTextParent ts = foldl' (toMapTextParent' ts)
 189   where
 190
 191     toMapTextParent' :: Set Text
 192                     -> Map Text (Map Parent Int)
 193                     -> Map Text NgramsRepoElement
 194                     -> Map Text (Map Parent Int)
 195     toMapTextParent' ts' to from = Set.foldl' (toMapTextParent'' from) to ts'
 196
 197
 198     toMapTextParent'' :: Map Text NgramsRepoElement
 199                       -> Map Text (Map Parent Int)
 200                       -> Text
 201                       -> Map Text (Map Parent Int)
 202     toMapTextParent'' from to t = case Map.lookup t from of
 203       Nothing  -> to
 204       Just nre -> case _nre_parent nre of
 205         Just (NgramsTerm p')  -> Map.alter (addParent p') t to
 206           where
 207             addParent p'' Nothing   = Just $ addCountParent p'' Map.empty
 208             addParent p'' (Just ps) = Just $ addCountParent p'' ps
 209         _ -> to
 210
 211 addCountParent :: Parent -> Map Parent Int -> Map Parent Int
 212 addCountParent p m = Map.alter addCount p m
 213   where
 214     addCount Nothing  = Just 1
 215     addCount (Just n) = Just $ n + 1
 216
 217
 218 ------------------------------------------------------------------------
 219 toList :: Map Text NgramsRepoElement -> (Text, NgramsRepoElement) -> [(Text, ListType)]
 220 toList m (t, nre@(NgramsRepoElement _ _ _ _ (MSet children))) =
 221      List.zip terms (List.cycle [lt'])
 222       where
 223         terms =  [t]
 224               -- <> maybe [] (\n -> [unNgramsTerm n]) root
 225               -- <> maybe [] (\n -> [unNgramsTerm n]) parent
 226               <> (map unNgramsTerm $ Map.keys children)
 227         lt'   = listOf m nre
 228
 229 listOf :: Map Text NgramsRepoElement -> NgramsRepoElement -> ListType
 230 listOf m ng = case _nre_parent ng of
 231   Nothing -> _nre_list ng
 232   Just  p -> case Map.lookup (unNgramsTerm p) m of
 233     Just ng' -> listOf m ng'
 234     Nothing  -> CandidateTerm
 235     -- panic "[G.C.T.L.Social.listOf] Nothing: Should Not happen"
 236
 237 ------------------------------------------------------------------------
 238 countList :: Text
 239           -> Map Text ListType
 240           -> Map Text (Map ListType Int)
 241           -> Map Text (Map ListType Int)
 242 countList t m input = case Map.lookup t m of
 243   Nothing -> input
 244   Just l  -> Map.alter addList t input
 245     where
 246       addList Nothing   = Just $ addCountList l Map.empty
 247       addList (Just lm) = Just $ addCountList l lm
 248
 249 addCountList :: ListType -> Map ListType Int -> Map ListType Int
 250 addCountList l m = Map.alter (plus l) l  m
 251   where
 252     plus CandidateTerm Nothing  = Just 1
 253     plus CandidateTerm (Just x) = Just $ x + 1
 254
 255     plus _ Nothing              = Just 3
 256     plus _ (Just x)             = Just $ x + 3
 257
 258 ------------------------------------------------------------------------
 259 findListsId :: (HasNodeError err, HasTreeError err)
 260             => NodeMode -> User -> Cmd err [NodeId]
 261 findListsId mode u = do
 262   r <- getRootId u
 263   ns <- map _dt_nodeId <$> filter (\n -> _dt_typeId n == nodeTypeId NodeList)
 264                        <$> findNodes' mode r
 265   -- printDebug "findListsIds" ns
 266   pure ns
 267
 268
 269 findNodes' :: HasTreeError err
 270           => NodeMode -> RootId
 271           -> Cmd err [DbTreeNode]
 272 findNodes' Private r = findNodes Private r $ [NodeFolderPrivate] <> commonNodes
 273 findNodes' Shared  r = findNodes Shared  r $ [NodeFolderShared ] <> commonNodes
 274 findNodes' Public  r = findNodes Public  r $ [NodeFolderPublic ] <> commonNodes
 275
 276 commonNodes:: [NodeType]
 277 commonNodes = [NodeFolder, NodeCorpus, NodeList]
 278