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

   1 {-|
   2 Module      : Gargantext.Core.Text.List.Group
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# LANGUAGE TemplateHaskell        #-}
  13 {-# LANGUAGE ConstraintKinds        #-}
  14 {-# LANGUAGE TypeFamilies           #-}
  15 {-# LANGUAGE FunctionalDependencies #-}
  16
  17
  18 module Gargantext.Core.Text.List.Group
  19   where
  20
  21 import Control.Lens (set, view)
  22 import Data.Set (Set)
  23 import Data.Map (Map)
  24 import Data.Maybe (fromMaybe)
  25 import Data.Text (Text)
  26 import Gargantext.Core.Types (ListType(..))
  27 import Gargantext.Database.Admin.Types.Node (NodeId)
  28 import Gargantext.Core.Text.List.Social.Prelude
  29 import Gargantext.Core.Text.List.Group.Prelude
  30 import Gargantext.Core.Text.List.Group.WithStem
  31 import Gargantext.Core.Text.List.Group.WithScores
  32 import Gargantext.Prelude
  33 import qualified Data.Set  as Set
  34 import qualified Data.Map  as Map
  35 import qualified Data.List as List
  36
  37 ------------------------------------------------------------------------
  38 -- | TODO add group with stemming
  39 toGroupedTreeText :: GroupParams
  40                   -> FlowCont Text FlowListScores
  41                   -> Map Text (Set NodeId)
  42                   -> Map Text (GroupedTreeScores (Set NodeId))
  43 toGroupedTreeText groupParams flc scores = view flc_scores flow2
  44     where
  45       flow1 = groupWithScores' flc scoring
  46       scoring t = fromMaybe Set.empty $ Map.lookup t scores
  47
  48       flow2 = case (view flc_cont flow1) == Map.empty of
  49         True  -> flow1
  50         False -> groupWithStem' groupParams flow1
  51
  52
  53 ------------------------------------------------------------------------
  54 ------------------------------------------------------------------------
  55 -- | TODO To be removed
  56 toGroupedText :: GroupedTextParams a b
  57               -> Map Text FlowListScores
  58               -> Map Text (Set NodeId)
  59               -> Map Stem (GroupedText Int)
  60 toGroupedText groupParams scores =
  61   (groupWithStem groupParams) . (groupWithScores scores)
  62
  63
  64 addListType :: Map Text ListType -> GroupedText a -> GroupedText a
  65 addListType m g = set gt_listType (hasListType m g) g
  66   where
  67     hasListType :: Map Text ListType -> GroupedText a -> Maybe ListType
  68     hasListType m' (GroupedText _ label _ g' _ _ _) =
  69         List.foldl' (<>) Nothing
  70       $ map (\t -> Map.lookup t m')
  71       $ Set.toList
  72       $ Set.insert label g'