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 (view)
  22 import Data.Map (Map)
  23 import Data.Maybe (fromMaybe)
  24 import Data.Monoid (Monoid, mempty)
  25 import Data.Text (Text)
  26 import Gargantext.Core.Text.List.Social.Prelude
  27 import Gargantext.Core.Text.List.Group.Prelude
  28 import Gargantext.Core.Text.List.Group.WithStem
  29 import Gargantext.Core.Text.List.Group.WithScores
  30 import Gargantext.Prelude
  31 import qualified Data.Map  as Map
  32
  33 ------------------------------------------------------------------------
  34 -- | TODO add group with stemming
  35 toGroupedTree :: (Ord a, Monoid a, GroupWithStem a)
  36               => GroupParams
  37               -> FlowCont Text FlowListScores
  38               -> Map Text a
  39              -- -> Map Text (GroupedTreeScores (Set NodeId))
  40               -> FlowCont Text (GroupedTreeScores a)
  41 toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
  42     where
  43       flow1     = groupWithScores' flc scoring
  44       scoring t = fromMaybe mempty $ Map.lookup t scores
  45
  46       flow2 = case (view flc_cont flow1) == Map.empty of
  47         True  -> flow1
  48         False -> groupWithStem' groupParams flow1
  49
  50
  51
  52 ------------------------------------------------------------------------
  53 setScoresWithMap :: (Ord a, Ord b, Monoid b) => Map Text b
  54                  -> Map Text (GroupedTreeScores a)
  55                  -> Map Text (GroupedTreeScores b)
  56 setScoresWithMap m = setScoresWith (score m)
  57   where
  58     score m' t = case Map.lookup t m' of
  59       Nothing -> mempty
  60       Just  r -> r
  61
  62 setScoresWith :: (Ord a, Ord b)
  63               => (Text -> b)
  64               -> Map Text (GroupedTreeScores a)
  65               -> Map Text (GroupedTreeScores b)
  66 {-
  67 -- | This Type level lenses solution does not work
  68 setScoresWith f = Map.mapWithKey (\k v -> over gts'_children (setScoresWith f)
  69                                        $  set  gts'_score    (f k) v
  70                                  )
  71 -}
  72 setScoresWith f = Map.mapWithKey (\k v -> v { _gts'_score    = f k
  73                                             , _gts'_children = setScoresWith f
  74                                                              $ view gts'_children v
  75                                             }
  76                                  )
  77
  78
  79 ------------------------------------------------------------------------