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.WithScores
  29 import Gargantext.Prelude
  30 import qualified Data.Map  as Map
  31
  32 ------------------------------------------------------------------------
  33 toGroupedTree :: (Ord a, Monoid a)
  34               => FlowCont Text FlowListScores
  35               -> Map Text a
  36               -> FlowCont Text (GroupedTreeScores a)
  37 toGroupedTree flc scores =
  38   groupWithScores' flc scoring
  39     where
  40       scoring t = fromMaybe mempty $ Map.lookup t scores
  41
  42
  43 ------------------------------------------------------------------------
  44 setScoresWithMap :: (Ord a, Ord b, Monoid b) => Map Text b
  45                  -> Map Text (GroupedTreeScores a)
  46                  -> Map Text (GroupedTreeScores b)
  47 setScoresWithMap m = setScoresWith (score m)
  48   where
  49     score m' t = case Map.lookup t m' of
  50       Nothing -> mempty
  51       Just  r -> r
  52
  53 setScoresWith :: (Ord a, Ord b)
  54               => (Text -> b)
  55               -> Map Text (GroupedTreeScores a)
  56               -> Map Text (GroupedTreeScores b)
  57 {-
  58 -- | This Type level lenses solution does not work
  59 setScoresWith f = Map.mapWithKey (\k v -> over gts'_children (setScoresWith f)
  60                                        $  set  gts'_score    (f k) v
  61                                  )
  62 -}
  63 setScoresWith f = Map.mapWithKey (\k v -> v { _gts'_score    = f k
  64                                             , _gts'_children = setScoresWith f
  65                                                              $ view gts'_children v
  66                                             }
  67                                  )
  68 ------------------------------------------------------------------------