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 {-# LANGUAGE InstanceSigs           #-}
  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.Monoid (mempty)
  26 import Data.Text (Text)
  27 import Gargantext.Core.Types (ListType(..))
  28 import Gargantext.Database.Admin.Types.Node (NodeId)
  29 import Gargantext.Core.Text.List.Social.Prelude
  30 import Gargantext.Core.Text.List.Group.Prelude
  31 import Gargantext.Core.Text.List.Group.WithStem
  32 import Gargantext.Core.Text.List.Group.WithScores
  33 import Gargantext.Prelude
  34 import qualified Data.Set  as Set
  35 import qualified Data.Map  as Map
  36 import qualified Data.List as List
  37
  38 ------------------------------------------------------------------------
  39 -- | TODO add group with stemming
  40
  41 class ToGroupedTree a b | a -> b where
  42   toGroupedTree :: GroupParams
  43                 -> FlowCont Text FlowListScores
  44                 -> a
  45                 -> FlowCont Text (GroupedTreeScores b)
  46
  47 instance ToGroupedTree (Map Text (Set NodeId)) (Set NodeId)
  48   where
  49     toGroupedTree :: GroupParams
  50                   -> FlowCont Text FlowListScores
  51                   -> Map Text (Set NodeId)
  52                  -- -> Map Text (GroupedTreeScores (Set NodeId))
  53                   -> FlowCont Text (GroupedTreeScores (Set NodeId))
  54     toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
  55         where
  56           flow1     = groupWithScores' flc scoring
  57           scoring t = fromMaybe Set.empty $ Map.lookup t scores
  58
  59           flow2 = case (view flc_cont flow1) == Map.empty of
  60             True  -> flow1
  61             False -> groupWithStem' groupParams flow1
  62
  63 instance ToGroupedTree (Map Text Double) Double
  64   where
  65     toGroupedTree :: GroupParams
  66                   -> FlowCont Text FlowListScores
  67                   -> Map Text Double
  68                  -- -> Map Text (GroupedTreeScores (Set NodeId))
  69                   -> FlowCont Text (GroupedTreeScores Double)
  70     toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
  71         where
  72           flow1     = groupWithScores' flc scoring
  73           scoring t = fromMaybe mempty $ Map.lookup t scores
  74
  75           flow2 = case (view flc_cont flow1) == Map.empty of
  76             True  -> flow1
  77             False -> groupWithStem' groupParams flow1
  78
  79 ------------------------------------------------------------------------
  80 ------------------------------------------------------------------------
  81 -- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
  82 -- | TODO To be removed
  83 toGroupedText :: GroupedTextParams a b
  84               -> Map Text FlowListScores
  85               -> Map Text (Set NodeId)
  86               -> Map Stem (GroupedText Int)
  87 toGroupedText groupParams scores =
  88   (groupWithStem groupParams) . (groupWithScores scores)
  89
  90
  91 addListType :: Map Text ListType -> GroupedText a -> GroupedText a
  92 addListType m g = set gt_listType (hasListType m g) g
  93   where
  94     hasListType :: Map Text ListType -> GroupedText a -> Maybe ListType
  95     hasListType m' (GroupedText _ label _ g' _ _ _) =
  96         List.foldl' (<>) Nothing
  97       $ map (\t -> Map.lookup t m')
  98       $ Set.toList
  99       $ Set.insert label g'