]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Core/Text/List/Group.hs
[FIX] Cont can be empty now.
[gargantext.git] / 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 -> FlowCont Text (GroupedTreeScores (Set NodeId))
44 toGroupedTreeText groupParams flc scores = {-view flc_scores-} flow2
45 where
46 flow1 = groupWithScores' flc scoring
47 scoring t = fromMaybe Set.empty $ Map.lookup t scores
48
49 flow2 = case (view flc_cont flow1) == Map.empty of
50 True -> flow1
51 False -> groupWithStem' groupParams flow1
52
53
54 ------------------------------------------------------------------------
55 ------------------------------------------------------------------------
56 -- | TODO To be removed
57 toGroupedText :: GroupedTextParams a b
58 -> Map Text FlowListScores
59 -> Map Text (Set NodeId)
60 -> Map Stem (GroupedText Int)
61 toGroupedText groupParams scores =
62 (groupWithStem groupParams) . (groupWithScores scores)
63
64
65 addListType :: Map Text ListType -> GroupedText a -> GroupedText a
66 addListType m g = set gt_listType (hasListType m g) g
67 where
68 hasListType :: Map Text ListType -> GroupedText a -> Maybe ListType
69 hasListType m' (GroupedText _ label _ g' _ _ _) =
70 List.foldl' (<>) Nothing
71 $ map (\t -> Map.lookup t m')
72 $ Set.toList
73 $ Set.insert label g'