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 import Control.Monad (mzero)
  15 import Data.Aeson
  16 import Data.HashMap.Strict (HashMap)
  17 import Data.Map (Map)
  18 import Data.Monoid (mconcat)
  19 import Gargantext.API.Ngrams.Tools
  20 import Gargantext.API.Ngrams.Types
  21 import Gargantext.Core.NodeStory
  22 import Gargantext.Core.Text.List.Social.Find
  23 import Gargantext.Core.Text.List.Social.History
  24 import Gargantext.Core.Text.List.Social.Patch
  25 import Gargantext.Core.Text.List.Social.Prelude
  26 import Gargantext.Core.Types.Individu
  27 import Gargantext.Database.Admin.Types.Node
  28 import Gargantext.Database.Prelude
  29 import Gargantext.Database.Query.Table.Node.Error
  30 import Gargantext.Database.Query.Tree
  31 import Gargantext.Database.Schema.Ngrams
  32 import Gargantext.Prelude
  33
  34 ------------------------------------------------------------------------
  35 ------------------------------------------------------------------------
  36 -- | Main parameters
  37
  38 -- | FlowSocialListPriority
  39 -- Sociological assumption: either private or others (public) first
  40 -- This parameter depends on the user choice
  41
  42 data FlowSocialListWith = FlowSocialListWithPriority { fslw_priority :: FlowSocialListPriority }
  43                         | FlowSocialListWithLists    { fslw_lists :: [ListId] }
  44 instance FromJSON FlowSocialListWith where
  45   parseJSON (Object v) = do
  46     typ <- v .: "type"
  47     value <- v .:? "value" .!= []
  48     case typ of
  49       "MyListsFirst" -> pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
  50       "OtherListsFirst" -> pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
  51       "SelectedLists" -> pure $ FlowSocialListWithLists { fslw_lists = v }
  52       _ -> pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
  53   parseJSON _ = mzero
  54
  55 data FlowSocialListPriority = MySelfFirst | OthersFirst
  56 flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
  57 flowSocialListPriority MySelfFirst = [Private{-, Shared, Public -}]
  58 flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
  59
  60 {-
  61 -- | We keep the parents for all ngrams but terms
  62 keepAllParents :: NgramsType -> KeepAllParents
  63 keepAllParents NgramsTerms = KeepAllParents False
  64 keepAllParents _           = KeepAllParents True
  65 -}
  66
  67 ------------------------------------------------------------------------
  68 flowSocialList :: ( HasNodeStory env err m
  69                    , CmdM     env err m
  70                    , HasNodeError err
  71                    , HasTreeError err
  72                    )
  73                   => Maybe FlowSocialListWith
  74                   -> User
  75                   -> NgramsType
  76                   -> FlowCont NgramsTerm FlowListScores
  77                   -> m (FlowCont NgramsTerm FlowListScores)
  78 flowSocialList Nothing u = flowSocialList' MySelfFirst u
  79 flowSocialList (Just (FlowSocialListWithPriority p)) u = flowSocialList' p u
  80 flowSocialList (Just (FlowSocialListWithLists    ls)) _ = getHistoryScores ls History_User
  81
  82 flowSocialList' :: ( HasNodeStory env err m
  83                    , CmdM     env err m
  84                    , HasNodeError err
  85                    , HasTreeError err
  86                    )
  87                   => FlowSocialListPriority
  88                   -> User -> NgramsType
  89                   -> FlowCont NgramsTerm FlowListScores
  90                   -> m (FlowCont NgramsTerm FlowListScores)
  91 flowSocialList' flowPriority user nt flc =
  92   mconcat <$> mapM (flowSocialListByMode'   user nt flc)
  93                    (flowSocialListPriority flowPriority)
  94     where
  95
  96       flowSocialListByMode' :: ( HasNodeStory env err m
  97                                , CmdM     env err m
  98                                , HasNodeError err
  99                                , HasTreeError err
 100                                )
 101                             => User -> NgramsType
 102                             -> FlowCont NgramsTerm FlowListScores
 103                             -> NodeMode
 104                             -> m (FlowCont NgramsTerm FlowListScores)
 105       flowSocialListByMode' user' nt' flc' mode =
 106             findListsId user' mode
 107         >>= flowSocialListByModeWith nt' flc'
 108
 109
 110       flowSocialListByModeWith :: ( HasNodeStory env err m
 111                                   , CmdM     env err m
 112                                   , HasNodeError err
 113                                   , HasTreeError err
 114                                   )
 115                                => NgramsType
 116                                -> FlowCont NgramsTerm FlowListScores
 117                                -> [ListId]
 118                                -> m (FlowCont NgramsTerm FlowListScores)
 119       flowSocialListByModeWith nt'' flc'' listes =
 120         getHistoryScores listes History_User nt'' flc''
 121
 122
 123 -----------------------------------------------------------------
 124 getHistoryScores :: ( HasNodeStory env err m
 125                     , CmdM         env err m
 126                     , HasNodeError     err
 127                     , HasTreeError     err
 128                     )
 129                  => [ListId]
 130                  -> History
 131                  -> NgramsType
 132                  -> FlowCont NgramsTerm FlowListScores
 133                  -> m (FlowCont NgramsTerm FlowListScores)
 134 getHistoryScores lists hist nt fl =
 135   addScorePatches nt lists fl <$> getHistory hist nt lists
 136
 137 getHistory :: ( HasNodeStory env err m
 138               , CmdM     env err m
 139               , HasNodeError err
 140               , HasTreeError err
 141               )
 142            => History
 143            -> NgramsType
 144            -> [ListId]
 145            -> m (Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch]))
 146 getHistory hist nt listes =
 147   history hist [nt] listes  <$> getRepo' listes
 148