[REFACT] toGroupedTree done for Ngrams Terms

src/Gargantext/Core/Text/List.hs

@@ -153,9 +153,9 @@ buildNgramsTermsList user uCid mCid groupParams (nt, mapListSize)= do
                $ Map.filter (not . ((==) Map.empty) . (view fls_parents))
                $ view flc_scores socialLists'
 
+-}
   let
     groupedWithList = toGroupedTree groupParams socialLists' allTerms
--}
 
 -- TODO remove
 -- 8<-- 8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--

src/Gargantext/Core/Text/List/Group.hs

@@ -53,14 +53,13 @@ instance ToGroupedTree (Map Text (Set NodeId)) (Set NodeId)
                   -> FlowCont Text (GroupedTreeScores (Set NodeId))
     toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
         where
-          flow1     = groupWithScores'' flc scoring
+          flow1     = groupWithScores' flc scoring
           scoring t = fromMaybe Set.empty $ Map.lookup t scores
 
           flow2 = case (view flc_cont flow1) == Map.empty of
             True  -> flow1
             False -> groupWithStem' groupParams flow1
 
-{-
 instance ToGroupedTree (Map Text Double) Double
   where
     toGroupedTree :: GroupParams
@@ -70,13 +69,12 @@ instance ToGroupedTree (Map Text Double) Double
                   -> FlowCont Text (GroupedTreeScores Double)
     toGroupedTree groupParams flc scores = {-view flc_scores-} flow2
         where
-          flow1     = groupWithScores'' flc scoring
+          flow1     = groupWithScores' flc scoring
           scoring t = fromMaybe mempty $ Map.lookup t scores
 
           flow2 = case (view flc_cont flow1) == Map.empty of
             True  -> flow1
             False -> groupWithStem' groupParams flow1
--}
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------

src/Gargantext/Core/Text/List/Group/WithScores.hs

@@ -19,7 +19,7 @@ import Control.Lens (makeLenses, view, set, over)
 import Data.Semigroup
 import Data.Set (Set)
 import Data.Map (Map)
-import Data.Monoid (mempty)
+import Data.Monoid (Monoid, mempty)
 import Data.Maybe (catMaybes, fromMaybe)
 import Data.Text (Text)
 import Gargantext.Core.Types (ListType(..))
@@ -31,23 +31,12 @@ import qualified Data.Map  as Map
 import qualified Data.Set  as Set
 
 ------------------------------------------------------------------------
-------------------------------------------------------------------------
-class GroupWithScore a where
-  groupWithScores'' :: FlowCont Text FlowListScores
-                    -> (Text -> a) -- Map Text (Set NodeId)
-                    -> FlowCont Text (GroupedTreeScores a)
-
-
-
 ------------------------------------------------------------------------
 -- | Main function
-
-instance GroupWithScore (Set NodeId) where
-  groupWithScores'' = groupWithScores'
-
-groupWithScores' :: FlowCont Text FlowListScores
-                 -> (Text -> Set NodeId) -- Map Text (Set NodeId)
-                 -> FlowCont Text (GroupedTreeScores (Set NodeId))
+groupWithScores' :: (Eq a, Ord a, Monoid a)
+                => FlowCont Text FlowListScores
+                -> (Text -> a) -- Map Text (a)
+                -> FlowCont Text (GroupedTreeScores (a))
 groupWithScores' flc scores = FlowCont  groups orphans
   where
     -- parent/child relation is inherited from social lists
@@ -60,16 +49,18 @@ groupWithScores' flc scores = FlowCont  groups orphans
             $ toMapMaybeParent scores
             $ view flc_cont flc
 ------------------------------------------------------------------------
-toMapMaybeParent :: (Text -> Set NodeId)
+toMapMaybeParent :: (Eq a, Ord a, Monoid a)
+                 => (Text -> a)
                  -> Map Text FlowListScores
-                 -> Map (Maybe Parent) (Map Text (GroupedTreeScores (Set NodeId)))
+                 -> Map (Maybe Parent) (Map Text (GroupedTreeScores (a)))
 toMapMaybeParent f =  Map.fromListWith (<>)
                    . (map (fromScores'' f))
                    .  Map.toList
 
-fromScores'' :: (Text -> Set NodeId)
+fromScores'' :: (Eq a, Ord a, Monoid a)
+             => (Text -> a)
              -> (Text, FlowListScores)
-             -> (Maybe Parent, Map Text (GroupedTreeScores (Set NodeId)))
+             -> (Maybe Parent, Map Text (GroupedTreeScores (a)))
 fromScores'' f' (t, fs) = ( maybeParent
                           , Map.fromList [( t, set gts'_score (f' t)
                                              $ set gts'_listType maybeList mempty
@@ -79,15 +70,17 @@ fromScores'' f' (t, fs) = ( maybeParent
      maybeParent = keyWithMaxValue $ view fls_parents  fs
      maybeList   = keyWithMaxValue $ view fls_listType fs
 
-toGroupedTree :: Map (Maybe Parent) (Map Text (GroupedTreeScores (Set NodeId)))
-              -> Map Parent (GroupedTreeScores (Set NodeId))
+toGroupedTree :: Eq a
+              => Map (Maybe Parent) (Map Text (GroupedTreeScores (a)))
+              -> Map Parent (GroupedTreeScores (a))
 toGroupedTree m = case Map.lookup Nothing m of
   Nothing  -> mempty
   Just  m' -> toGroupedTree' m m'
 
-toGroupedTree' :: Map (Maybe Parent) (Map Text (GroupedTreeScores (Set NodeId)))
-               -> (Map Text (GroupedTreeScores (Set NodeId)))
-               -> Map Parent (GroupedTreeScores (Set NodeId))
+
+toGroupedTree' :: Eq a => Map (Maybe Parent) (Map Text (GroupedTreeScores (a)))
+               -> (Map Text (GroupedTreeScores (a)))
+               ->  Map Parent (GroupedTreeScores (a))
 toGroupedTree' m notEmpty
   | notEmpty == mempty = mempty
   | otherwise = Map.mapWithKey (addGroup m) notEmpty

src/Gargantext/Prelude.hs

@@ -35,6 +35,8 @@ import GHC.Err.Located (undefined)
 import GHC.Real (round)
 import Data.Map (Map, lookup)
 import Data.Maybe (isJust, fromJust, maybe)
+import Data.Monoid (Monoid, mempty)
+import Data.Semigroup (Semigroup, (<>))
 import Data.Text (Text)
 import Data.Typeable (Typeable)
 import Protolude ( Bool(True, False), Int, Int64, Double, Integer
@@ -306,12 +308,18 @@ lookup2 a b m = do
   m' <- lookup a m
   lookup b m'
 
------------------------------------------------
-
+-----------------------------------------------------------------------
 foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
 foldM' _ z [] = return z
 foldM' f z (x:xs) = do
   z' <- f z x
   z' `seq` foldM' f z' xs
 
+-----------------------------------------------------------------------
+
+instance Monoid Double where
+  mempty = 0
+
+instance Semigroup Double where
+  (<>) a b = a * b