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, over)
  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
  56
  57 ------------------------------------------------------------------------
  58 setScoresWithMap :: (Ord a, Ord b, Monoid b) => Map Text b
  59                  -> Map Text (GroupedTreeScores a)
  60                  -> Map Text (GroupedTreeScores b)
  61 setScoresWithMap m = setScoresWith (score m)
  62   where
  63     score m t = case Map.lookup t m of
  64       Nothing -> mempty
  65       Just  r -> r
  66
  67 setScoresWith :: (Ord a, Ord b)
  68               => (Text -> b)
  69               -> Map Text (GroupedTreeScores a)
  70               -> Map Text (GroupedTreeScores b)
  71 {-
  72 -- | This Type level lenses solution does not work
  73 setScoresWith f = Map.mapWithKey (\k v -> over gts'_children (setScoresWith f)
  74                                        $  set  gts'_score    (f k) v
  75                                  )
  76 -}
  77 setScoresWith f = Map.mapWithKey (\k v -> v { _gts'_score    = f k
  78                                             , _gts'_children = setScoresWith f
  79                                                              $ view gts'_children v
  80                                             }
  81                                  )
  82
  83
  84 ------------------------------------------------------------------------