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