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 (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 toGroupedTree :: (Ord a, Monoid a, GroupWithStem a)
  41               => GroupParams
  42               -> FlowCont Text FlowListScores
  43               -> Map Text a
  44              -- -> Map Text (GroupedTreeScores (Set NodeId))
  45               -> FlowCont Text (GroupedTreeScores a)
  46 toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
  47     where
  48       flow1     = groupWithScores' flc scoring
  49       scoring t = fromMaybe mempty $ Map.lookup t scores
  50
  51       flow2 = case (view flc_cont flow1) == Map.empty of
  52         True  -> flow1
  53         False -> groupWithStem' groupParams flow1
  54
  55 setScoresWith :: Map Text a
  56               -> Map Text (GroupedTreeScores b)
  57               -> Map Text (GroupedTreeScores a)
  58 setScoresWith = undefined
  59
  60
  61 ------------------------------------------------------------------------
  62 ------------------------------------------------------------------------
  63 -- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--
  64 -- | TODO To be removed
  65 toGroupedText :: GroupedTextParams a b
  66               -> Map Text FlowListScores
  67               -> Map Text (Set NodeId)
  68               -> Map Stem (GroupedText Int)
  69 toGroupedText groupParams scores =
  70   (groupWithStem groupParams) . (groupWithScores scores)
  71
  72
  73 addListType :: Map Text ListType -> GroupedText a -> GroupedText a
  74 addListType m g = set gt_listType (hasListType m g) g
  75   where
  76     hasListType :: Map Text ListType -> GroupedText a -> Maybe ListType
  77     hasListType m' (GroupedText _ label _ g' _ _ _) =
  78         List.foldl' (<>) Nothing
  79       $ map (\t -> Map.lookup t m')
  80       $ Set.toList
  81       $ Set.insert label g'