[REFACT] Continuation Type with Monoid instance, connected to flowSocialList

src/Gargantext/Core/Text/List.hs

@@ -32,7 +32,6 @@ import qualified Data.Text as Text
 import Gargantext.API.Ngrams.Types (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList)
 import Gargantext.API.Ngrams.Types (RepoCmdM)
 import Gargantext.Core.Text.List.Social
-import Gargantext.Core.Text.List.Social.Scores
 import Gargantext.Core.Text.List.Social.Prelude
 import Gargantext.Core.Text.List.Group
 import Gargantext.Core.Text.List.Group.WithStem
@@ -87,15 +86,17 @@ buildNgramsOthersList ::( HasNodeError err
 buildNgramsOthersList user uCid groupIt (nt, MapListSize mapListSize) = do
   ngs'  :: Map Text (Set NodeId) <- getNodesByNgramsUser uCid nt
 
-  socialLists' :: Map Text FlowListScores
-    <- flowSocialList' MySelfFirst user nt (Set.fromList $ Map.keys ngs')
+  socialLists' :: FlowListCont Text
+    <- flowSocialList' MySelfFirst user nt (FlowListCont Map.empty $ Set.fromList $ Map.keys ngs')
     -- PrivateFirst for first developments since Public NodeMode is not implemented yet
 
-  printDebug "flowSocialList'" (Map.filter (not . ((==) Map.empty) . view fls_parents) socialLists')
+  printDebug "flowSocialList'"
+               $ Map.filter (not . ((==) Map.empty) . view fls_parents)
+               $ view flc_scores socialLists'
 
   let
     groupParams     = GroupedTextParams groupIt (Set.size . snd) fst snd {-(size . fst)-}
-    groupedWithList = toGroupedText groupParams socialLists' ngs'
+    groupedWithList = toGroupedText groupParams (view flc_scores socialLists') ngs'
 
   printDebug "groupedWithList"
                $ Map.map (\v -> (view gt_label v, view gt_children v))

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

@@ -24,7 +24,7 @@ import Data.Map (Map)
 import Data.Text (Text)
 import Gargantext.Core.Types (ListType(..))
 import Gargantext.Database.Admin.Types.Node (NodeId)
-import Gargantext.Core.Text.List.Social.Scores (FlowListScores(..))
+import Gargantext.Core.Text.List.Social.Prelude (FlowListScores(..))
 import Gargantext.Core.Text.List.Group.WithStem
 import Gargantext.Core.Text.List.Group.WithScores
 import Gargantext.Prelude

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

@@ -22,9 +22,7 @@ import Data.Maybe (catMaybes)
 import Data.Text (Text)
 import Gargantext.Core.Types (ListType(..)) -- (MasterCorpusId, UserCorpusId)
 import Gargantext.Database.Admin.Types.Node (NodeId)
--- import Gargantext.Core.Text.List.Learn (Model(..))
 import Gargantext.Core.Text.List.Social.Prelude
-import Gargantext.Core.Text.List.Social.Scores
 import Gargantext.Prelude
 import qualified Data.Set  as Set
 import qualified Data.Map  as Map

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

@@ -13,7 +13,7 @@ module Gargantext.Core.Text.List.Social
 
 import Data.Map (Map)
 import Data.Maybe (fromMaybe)
-import Data.Semigroup (Semigroup(..))
+import Data.Monoid (mconcat)
 import Data.Set (Set)
 import Data.Text (Text)
 import Gargantext.API.Ngrams.Tools -- (getListNgrams)
@@ -34,38 +34,10 @@ import qualified Data.Map   as Map
 import qualified Data.Set   as Set
 
 ------------------------------------------------------------------------
-flowSocialList :: ( RepoCmdM env err m
-                  , CmdM     env err m
-                  , HasNodeError err
-                  , HasTreeError err
-                  )
-                  => User -> NgramsType -> Set Text
-                  -> m (Map ListType (Set Text))
-flowSocialList user nt ngrams' = do
-  -- Here preference to privateLists (discutable: let user choice)
-  privateListIds <- findListsId user Private
-  privateLists <- flowSocialListByMode privateListIds nt ngrams'
-  -- printDebug "* privateLists *: \n" privateLists
-
-  sharedListIds <- findListsId user Shared
-  sharedLists  <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists)
-  -- printDebug "* sharedLists *: \n" sharedLists
-
-  -- TODO publicMapList:
-  -- Note: if both produce 3 identic repetition => refactor mode
-  -- publicListIds <- findListsId Public user
-  -- publicLists   <- flowSocialListByMode' publicListIds nt (termsByList CandidateTerm privateLists)
-
-  let result = parentUnionsExcl
-             [ Map.mapKeys (fromMaybe CandidateTerm) privateLists
-             , Map.mapKeys (fromMaybe CandidateTerm) sharedLists
-             -- , Map.mapKeys (fromMaybe CandidateTerm) publicLists
-             ]
-  -- printDebug "* socialLists *: results \n" result
-  pure result
-
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
+-- | Main parameters
+
 -- | FlowSocialListPriority
 -- Sociological assumption: either private or others (public) first
 -- This parameter depends on the user choice
@@ -75,6 +47,13 @@ flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
 flowSocialListPriority MySelfFirst = [Private, Shared{-, Public -}]
 flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
 
+
+-- | We keep the parents for all ngrams but terms
+keepAllParents :: NgramsType -> KeepAllParents
+keepAllParents NgramsTerms = KeepAllParents False
+keepAllParents _           = KeepAllParents True
+
+
 ------------------------------------------------------------------------
 flowSocialList' :: ( RepoCmdM env err m
                    , CmdM     env err m
@@ -82,37 +61,27 @@ flowSocialList' :: ( RepoCmdM env err m
                    , HasTreeError err
                    )
                   => FlowSocialListPriority
-                  -> User -> NgramsType -> Set Text
-                  -> m (Map Text FlowListScores)
-flowSocialList' flowPriority user nt ngrams' =
-  parentUnionsExcl <$> mapM (flowSocialListByMode' user nt ngrams')
-                            (flowSocialListPriority flowPriority)
+                  -> User -> NgramsType
+                  -> FlowListCont Text
+                  -> m (FlowListCont Text)
+flowSocialList' flowPriority user nt flc =
+  mconcat <$> mapM (flowSocialListByMode' user nt flc)
+                   (flowSocialListPriority flowPriority)
 
 ------------------------------------------------------------------------
-flowSocialListByMode :: ( RepoCmdM env err m
-                        , CmdM     env err m
-                        , HasNodeError err
-                        , HasTreeError err
-                        )
-                     => [NodeId]-> NgramsType -> Set Text
-                     -> m (Map (Maybe ListType) (Set Text))
-flowSocialListByMode      [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
-flowSocialListByMode listIds  nt ngrams' = do
-    counts  <- countFilterList ngrams' nt listIds Map.empty
-    let r = toSocialList counts ngrams'
-    pure r
-
 
 flowSocialListByMode' :: ( RepoCmdM env err m
                          , CmdM     env err m
                          , HasNodeError err
                          , HasTreeError err
                          )
-                      => User -> NgramsType -> Set Text -> NodeMode 
-                      -> m (Map Text FlowListScores)
-flowSocialListByMode' user nt st mode =
+                      => User -> NgramsType
+                      -> FlowListCont Text
+                      -> NodeMode
+                      -> m (FlowListCont Text)
+flowSocialListByMode' user nt flc mode =
       findListsId user mode
-  >>= flowSocialListByModeWith nt st
+  >>= flowSocialListByModeWith nt flc
 
 
 flowSocialListByModeWith :: ( RepoCmdM env err m
@@ -120,20 +89,19 @@ flowSocialListByModeWith :: ( RepoCmdM env err m
                             , HasNodeError err
                             , HasTreeError err
                             )
-                         => NgramsType -> Set Text -> [NodeId]
-                         -> m (Map Text FlowListScores)
-flowSocialListByModeWith nt st ns =
+                         => NgramsType
+                         -> FlowListCont Text
+                         -> [NodeId]
+                         -> m (FlowListCont Text)
+flowSocialListByModeWith nt flc ns =
       mapM (\l -> getListNgrams [l] nt) ns
   >>= pure
-    . toFlowListScores (keepAllParents nt) st Map.empty
+    . toFlowListScores (keepAllParents nt) flc
 
 
--- | We keep the parents for all ngrams but terms
-keepAllParents :: NgramsType -> KeepAllParents
-keepAllParents NgramsTerms = KeepAllParents False
-keepAllParents _           = KeepAllParents True
 
-------------------------------------------------------------------------
+---8<-TODO-ALL BELOW--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<--8<-
+
 -- | Choice depends on Ord instance of ListType
 -- for now : data ListType  =  StopTerm | CandidateTerm | MapTerm
 -- means MapTerm > CandidateTerm > StopTerm in case of equality of counts
@@ -167,3 +135,48 @@ toSocialList1_testIsTrue = result == (Just MapTerm, Set.singleton token)
                      ]
 
 
+
+flowSocialList :: ( RepoCmdM env err m
+                  , CmdM     env err m
+                  , HasNodeError err
+                  , HasTreeError err
+                  )
+                  => User -> NgramsType -> Set Text
+                  -> m (Map ListType (Set Text))
+flowSocialList user nt ngrams' = do
+  -- Here preference to privateLists (discutable: let user choice)
+  privateListIds <- findListsId user Private
+  privateLists <- flowSocialListByMode privateListIds nt ngrams'
+  -- printDebug "* privateLists *: \n" privateLists
+
+  sharedListIds <- findListsId user Shared
+  sharedLists  <- flowSocialListByMode sharedListIds nt (termsByList CandidateTerm privateLists)
+  -- printDebug "* sharedLists *: \n" sharedLists
+
+  -- TODO publicMapList:
+  -- Note: if both produce 3 identic repetition => refactor mode
+  -- publicListIds <- findListsId Public user
+  -- publicLists   <- flowSocialListByMode' publicListIds nt (termsByList CandidateTerm privateLists)
+
+  let result = parentUnionsExcl
+             [ Map.mapKeys (fromMaybe CandidateTerm) privateLists
+             , Map.mapKeys (fromMaybe CandidateTerm) sharedLists
+             -- , Map.mapKeys (fromMaybe CandidateTerm) publicLists
+             ]
+  -- printDebug "* socialLists *: results \n" result
+  pure result
+
+
+-- | TODO remove
+flowSocialListByMode :: ( RepoCmdM env err m
+                        , CmdM     env err m
+                        , HasNodeError err
+                        , HasTreeError err
+                        )
+                     => [NodeId]-> NgramsType -> Set Text
+                     -> m (Map (Maybe ListType) (Set Text))
+flowSocialListByMode      [] _nt ngrams' = pure $ Map.fromList [(Nothing, ngrams')]
+flowSocialListByMode listIds  nt ngrams' = do
+    counts  <- countFilterList ngrams' nt listIds Map.empty
+    let r = toSocialList counts ngrams'
+    pure r

src/Gargantext/Core/Text/List/Social/Prelude.hs

@@ -18,16 +18,66 @@ Portability : POSIX
 module Gargantext.Core.Text.List.Social.Prelude
   where
 
+import Control.Lens
 import Data.Semigroup (Semigroup(..))
+import Data.Monoid
 import Data.Map (Map)
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import Data.Text (Text)
 import Gargantext.Core.Types.Main
 import Gargantext.Prelude
+import GHC.Generics (Generic)
 import qualified Data.Map   as Map
 import qualified Data.Set   as Set
 
+------------------------------------------------------------------------
+type Parent = Text
+------------------------------------------------------------------------
+-- | DataType inspired by continuation Monad (but simpler)
+data FlowListCont a =
+  FlowListCont { _flc_scores :: Map a FlowListScores
+               , _flc_cont   :: Set a
+               }
+
+instance Ord a => Monoid (FlowListCont a) where
+  mempty = FlowListCont Map.empty Set.empty
+
+instance (Eq a, Ord a) => Semigroup (FlowListCont a) where
+  (<>) (FlowListCont m1 s1)
+       (FlowListCont m2 s2)
+          | s1 == Set.empty = FlowListCont m s2
+          | s2 == Set.empty = FlowListCont m s1
+          | otherwise       = FlowListCont m (Set.intersection s1 s2)
+            where
+              m = Map.union m1 m2
+
+
+-- | Datatype definition
+data FlowListScores =
+  FlowListScores { _fls_parents  :: Map Parent   Int
+                 , _fls_listType :: Map ListType Int
+                -- You can add any score by incrementing this type
+                -- , _flc_score   :: Map Score Int
+                 }
+    deriving (Show, Generic)
+
+
+------------------------------------------------------------------------
+makeLenses ''FlowListCont
+makeLenses ''FlowListScores
+
+-- | Rules to compose 2 datatype FlowListScores
+-- About the shape of the Type fun:
+-- Triangle de Pascal, nombre d'or ou pi ?
+-- Question: how to add a score field and derive such definition
+-- without the need to fix it below ?
+instance Semigroup FlowListScores where
+  (<>) (FlowListScores p1 l1)
+       (FlowListScores p2 l2) =
+        FlowListScores (p1 <> p2)
+                       (l1 <> l2)
+
 
 ------------------------------------------------------------------------
 -- | Tools to inherit groupings
@@ -49,8 +99,8 @@ parentUnionsExcl :: Ord a
                  ->  Map a b
 parentUnionsExcl = Map.unions
 
+
 ------------------------------------------------------------------------
-type Parent = Text
 
 hasParent :: Text
           -> Map Text (Map Parent Int)
@@ -76,9 +126,9 @@ termsByList l m =
   fromMaybe Set.empty $ Map.lookup (Just l) m
 
 ------------------------------------------------------------------------
-unions :: (Ord a, Semigroup a, Semigroup b, Ord b)
+unions' :: (Ord a, Semigroup a, Semigroup b, Ord b)
       => [Map a (Set b)] -> Map a (Set b)
-unions = invertBack . Map.unionsWith (<>) . map invertForw
+unions' = invertBack . Map.unionsWith (<>) . map invertForw
 
 invertForw :: (Ord b, Semigroup a) => Map a (Set b) -> Map b a
 invertForw = Map.unionsWith (<>)
@@ -91,7 +141,7 @@ invertBack = Map.fromListWith (<>)
            .  Map.toList
 
 unions_test :: Map ListType (Set Text)
-unions_test = unions [m1, m2]
+unions_test = unions' [m1, m2]
   where
     m1 = Map.fromList [ (StopTerm     , Set.singleton "Candidate")]
     m2 = Map.fromList [ (CandidateTerm, Set.singleton "Candidate")

src/Gargantext/Core/Text/List/Social/Scores.hs

@@ -19,10 +19,9 @@ module Gargantext.Core.Text.List.Social.Scores
 
 import Control.Lens
 import Data.Map (Map)
-import Data.Semigroup (Semigroup(..))
+import Data.Monoid (mempty)
 import Data.Set (Set)
 import Data.Text (Text)
-import GHC.Generics (Generic)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types.Main
 import Gargantext.Core.Text.List.Social.Prelude
@@ -30,66 +29,36 @@ import Gargantext.Prelude
 import qualified Data.Map   as Map
 import qualified Data.Set   as Set
 
-------------------------------------------------------------------------
--- | DataType inspired by continuation Monad (but simpler)
-data FlowListCont a =
-  FlowListCont { _flc_scores :: Map a FlowListScores
-               , _flc_cont   :: Set a
-               }
-
--- | Datatype definition
-data FlowListScores =
-  FlowListScores { _fls_parents  :: Map Parent   Int
-                 , _fls_listType :: Map ListType Int
-                -- You can add any score by incrementing this type
-                -- , _flc_score   :: Map Score Int
-                 }
-    deriving (Show, Generic)
-
-------------------------------------------------------------------------
-makeLenses ''FlowListCont
-makeLenses ''FlowListScores
-
--- | Rules to compose 2 datatype FlowListScores
--- About the shape of the Type fun:
--- Triangle de Pascal, nombre d'or ou pi ?
--- Question: how to add a score field and derive such definition
--- without the need to fix it below ?
-instance Semigroup FlowListScores where
-  (<>) (FlowListScores p1 l1)
-       (FlowListScores p2 l2) =
-        FlowListScores (p1 <> p2)
-                       (l1 <> l2)
-
-------------------------------------------------------------------------
 ------------------------------------------------------------------------
 -- | Generates Score from list of Map Text NgramsRepoElement
 toFlowListScores :: KeepAllParents
-                 -> Set Text
-                 ->  Map Text FlowListScores
+                 ->  FlowListCont Text
                  -> [Map Text NgramsRepoElement]
-                 ->  Map Text FlowListScores
-toFlowListScores k st = foldl' (toFlowListScores' k st)
+                 ->  FlowListCont Text
+toFlowListScores k flc = foldl' (toFlowListScores' k flc) mempty
   where
     toFlowListScores' :: KeepAllParents
-                     -> Set Text
-                     -> Map Text FlowListScores
+                     -> FlowListCont Text
+                     -> FlowListCont Text
                      -> Map Text NgramsRepoElement
-                     -> Map Text FlowListScores
-    toFlowListScores' k' st' to' ngramsRepo =
-      Set.foldl' (toFlowListScores'' k' st' ngramsRepo) to' st'
+                     -> FlowListCont Text
+    toFlowListScores' k' flc flc' ngramsRepo =
+      Set.foldl' (toFlowListScores'' k' ngramsRepo flc) flc' (view flc_cont flc)
+
 
     toFlowListScores'' :: KeepAllParents
-                       -> Set Text
                        -> Map Text NgramsRepoElement
-                       -> Map Text FlowListScores
+                       -> FlowListCont Text
+                       -> FlowListCont Text
                        -> Text
-                       -> Map Text FlowListScores
-    toFlowListScores'' k'' st'' ngramsRepo to'' t =
+                       -> FlowListCont Text
+    toFlowListScores'' k'' ngramsRepo flc to'' t =
       case Map.lookup t ngramsRepo of
-        Nothing  -> to''
-        Just nre -> Map.alter (addParent k'' nre st'')        t
-                  $ Map.alter (addList $ _nre_list nre) t to''
+        Nothing  -> over flc_cont (Set.insert t) to''
+        Just nre -> over flc_scores
+                  ( (Map.alter (addParent k'' nre (view flc_cont flc)) t)
+                  . (Map.alter (addList $ _nre_list nre) t)
+                  ) to''
 
 ------------------------------------------------------------------------
 -- | Main addFunctions to groupResolution the FlowListScores