[FEAT] enabling FlowSocialList With preferences

bin/gargantext-import/Main.hs

@@ -47,10 +47,10 @@ main = do
     tt = (Multi EN)
     format = CsvGargV3 -- CsvHal --WOS
     corpus :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
-    corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt  format corpusPath
+    corpus = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt  format corpusPath Nothing
 
     corpusCsvHal :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
-    corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath
+    corpusCsvHal = flowCorpusFile (UserName $ cs user) (Left (cs name :: Text)) (read limit :: Int) tt CsvHal corpusPath Nothing
 
     annuaire :: forall m. FlowCmdM DevEnv GargError m => m CorpusId
     annuaire = flowAnnuaire (UserName $ cs user) (Left "Annuaire") (Multi EN) corpusPath

src/Gargantext/API/Node/Contact.hs

@@ -92,7 +92,7 @@ addContact u nId (AddContactParams fn ln) logStatus = do
                    , _scst_remaining = Just 1
                    , _scst_events    = Just []
                    }
-  _ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) [[hyperdataContact fn ln]]
+  _ <- flow (Nothing :: Maybe HyperdataAnnuaire) u (Right [nId]) (Multi EN) Nothing [[hyperdataContact fn ln]]
 
   pure  JobLog { _scst_succeeded = Just 2
                , _scst_failed    = Just 0

src/Gargantext/API/Node/Corpus/New.hs

@@ -137,6 +137,7 @@ data WithQuery = WithQuery
   , _wq_datafield :: !Datafield
   , _wq_lang      :: !Lang
   , _wq_node_id   :: !Int
+  -- , _wq_flowListWith :: !FlowSocialListWith
   }
   deriving Generic
 
@@ -213,7 +214,7 @@ addToCorpusWithQuery user cid (WithQuery q dbs datafield l _nid) maybeLimit logS
                        , _scst_events    = Just []
                        }
 
-      cids <- mapM (\txt -> flowDataText user txt (Multi l) cid) txts
+      cids <- mapM (\txt -> flowDataText user txt (Multi l) cid Nothing) txts
       printDebug "corpus id" cids
       printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
       sendMail user
@@ -265,6 +266,7 @@ addToCorpusWithForm user cid (NewWithForm ft d l _n) logStatus jobLog = do
       _cid' <- flowCorpus user
                           (Right [cid])
                           (Multi $ fromMaybe EN l)
+                          Nothing
                           (map (map toHyperdataDocument) docs)
 
       printDebug "Extraction finished   : " cid

src/Gargantext/API/Search.hs

@@ -66,7 +66,7 @@ api nId (SearchQuery q SearchContact) o l order = do
             <$> SearchResultContact
             <$> map (toRow aId)
             <$> searchInCorpusWithContacts nId aId q o l order
-api _ _ _ _ _ = undefined
+api _ _ _ _ _ = panic "[G.A.Search.api] undefined"
 
 -----------------------------------------------------------------------
 -----------------------------------------------------------------------

src/Gargantext/Core/Text/List.hs

@@ -67,14 +67,15 @@ buildNgramsLists :: ( HasNodeStory env err m
                     , HasTreeError err
                     , HasNodeError err
                     )
-                 => GroupParams
-                 -> User
+                 => User
                  -> UserCorpusId
                  -> MasterCorpusId
+                 -> Maybe FlowSocialListWith
+                 -> GroupParams
                  -> m (Map NgramsType [NgramsElement])
-buildNgramsLists gp user uCid mCid = do
-  ngTerms     <- buildNgramsTermsList user uCid mCid gp (NgramsTerms, MapListSize 350)
-  othersTerms <- mapM (buildNgramsOthersList user uCid GroupIdentity)
+buildNgramsLists user uCid mCid mfslw gp = do
+  ngTerms     <- buildNgramsTermsList user uCid mCid mfslw gp (NgramsTerms, MapListSize 350)
+  othersTerms <- mapM (buildNgramsOthersList user uCid mfslw GroupIdentity)
                       [ (Authors   , MapListSize 9)
                       , (Sources   , MapListSize 9)
                       , (Institutes, MapListSize 9)
@@ -92,15 +93,16 @@ buildNgramsOthersList ::( HasNodeError err
                         )
                         => User
                         -> UserCorpusId
+                        -> Maybe FlowSocialListWith
                         -> GroupParams
                         -> (NgramsType, MapListSize)
                         -> m (Map NgramsType [NgramsElement])
-buildNgramsOthersList user uCid _groupParams (nt, MapListSize mapListSize) = do
+buildNgramsOthersList user uCid mfslw _groupParams (nt, MapListSize mapListSize) = do
   allTerms  :: HashMap NgramsTerm (Set NodeId) <- getNodesByNgramsUser uCid nt
 
   -- PrivateFirst for first developments since Public NodeMode is not implemented yet
   socialLists :: FlowCont NgramsTerm FlowListScores
-    <- flowSocialList MySelfFirst user nt ( FlowCont HashMap.empty
+    <- flowSocialList mfslw user nt ( FlowCont HashMap.empty
                                                       $ HashMap.fromList
                                                       $ List.zip (HashMap.keys allTerms)
                                                                  (List.cycle [mempty])
@@ -149,10 +151,11 @@ buildNgramsTermsList :: ( HasNodeError err
                         => User
                         -> UserCorpusId
                         -> MasterCorpusId
+                        -> Maybe FlowSocialListWith
                         -> GroupParams
                         -> (NgramsType, MapListSize)
                         -> m (Map NgramsType [NgramsElement])
-buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
+buildNgramsTermsList user uCid mCid mfslw groupParams (nt, _mapListSize)= do
 
 -- Filter 0 With Double
 -- Computing global speGen score
@@ -163,7 +166,7 @@ buildNgramsTermsList user uCid mCid groupParams (nt, _mapListSize)= do
   printDebug "[buldNgramsTermsList: Flow Social List / start]" nt
   -- PrivateFirst for first developments since Public NodeMode is not implemented yet
   socialLists :: FlowCont NgramsTerm FlowListScores
-    <- flowSocialList MySelfFirst user nt ( FlowCont HashMap.empty
+    <- flowSocialList mfslw user nt ( FlowCont HashMap.empty
                                                       $ HashMap.fromList
                                                       $ List.zip (HashMap.keys   allTerms)
                                                                  (List.cycle     [mempty])

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

@@ -36,8 +36,12 @@ import Gargantext.Prelude
 -- | FlowSocialListPriority
 -- Sociological assumption: either private or others (public) first
 -- This parameter depends on the user choice
-data FlowSocialListPriority = MySelfFirst | OthersFirst
 
+data FlowSocialListWith = FlowSocialListWithPriority { fslw_priority :: FlowSocialListPriority }
+                        | FlowSocialListWithLists    { fslw_lists :: [ListId] }
+
+
+data FlowSocialListPriority = MySelfFirst | OthersFirst
 flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
 flowSocialListPriority MySelfFirst = [Private{-, Shared, Public -}]
 flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
@@ -55,11 +59,25 @@ flowSocialList :: ( HasNodeStory env err m
                    , HasNodeError err
                    , HasTreeError err
                    )
+                  => Maybe FlowSocialListWith
+                  -> User
+                  -> NgramsType
+                  -> FlowCont NgramsTerm FlowListScores
+                  -> m (FlowCont NgramsTerm FlowListScores)
+flowSocialList Nothing u = flowSocialList' MySelfFirst u
+flowSocialList (Just (FlowSocialListWithPriority p)) u = flowSocialList' p u
+flowSocialList (Just (FlowSocialListWithLists    ls)) _ = getHistoryScores ls History_User
+
+flowSocialList' :: ( HasNodeStory env err m
+                   , CmdM     env err m
+                   , HasNodeError err
+                   , HasTreeError err
+                   )
                   => FlowSocialListPriority
                   -> User -> NgramsType
                   -> FlowCont NgramsTerm FlowListScores
                   -> m (FlowCont NgramsTerm FlowListScores)
-flowSocialList flowPriority user nt flc =
+flowSocialList' flowPriority user nt flc =
   mconcat <$> mapM (flowSocialListByMode'   user nt flc)
                    (flowSocialListPriority flowPriority)
     where
@@ -88,25 +106,22 @@ flowSocialList flowPriority user nt flc =
                                -> [ListId]
                                -> m (FlowCont NgramsTerm FlowListScores)
       flowSocialListByModeWith nt'' flc'' listes =
-        getHistoryScores History_User nt'' flc'' listes
-        {-
-            mapM (\l -> getListNgrams [l] nt'') listes
-        >>= pure
-          . toFlowListScores (keepAllParents nt'') flc''
-        -}
+        getHistoryScores listes History_User nt'' flc''
+
+
 -----------------------------------------------------------------
 getHistoryScores :: ( HasNodeStory env err m
                     , CmdM         env err m
                     , HasNodeError     err
                     , HasTreeError     err
                     )
-                 => History
+                 => [ListId]
+                 -> History
                  -> NgramsType
                  -> FlowCont NgramsTerm FlowListScores
-                 -> [ListId]
                  -> m (FlowCont NgramsTerm FlowListScores)
-getHistoryScores hist nt fl listes =
-  addScorePatches nt listes fl <$> getHistory hist nt listes
+getHistoryScores lists hist nt fl =
+  addScorePatches nt lists fl <$> getHistory hist nt lists
 
 getHistory :: ( HasNodeStory env err m
               , CmdM     env err m

src/Gargantext/Database/Action/Delete.hs

@@ -36,7 +36,9 @@ import Gargantext.Prelude
 import qualified Gargantext.Database.GargDB as GargDB
 
 ------------------------------------------------------------------------
-
+-- TODO
+-- Delete Corpus children accoring its types
+-- Delete NodeList (NodeStory + cbor file)
 deleteNode :: (HasConfig env, HasConnectionPool env, HasNodeError err)
            => User
            -> NodeId
@@ -44,7 +46,7 @@ deleteNode :: (HasConfig env, HasConnectionPool env, HasNodeError err)
 deleteNode u nodeId = do
   node' <- N.getNode nodeId
   case (view node_typename node') of
-    nt | nt == toDBid NodeUser -> panic "Not allowed to delete NodeUser (yet)"
+    nt | nt == toDBid NodeUser -> panic "[G.D.A.D.deleteNode] Not allowed to delete NodeUser (yet)"
     nt | nt == toDBid NodeTeam -> do
       uId   <- getUserId u
       if _node_user_id node' == uId

src/Gargantext/Database/Action/Flow.hs

@@ -72,6 +72,7 @@ import Gargantext.Core.Text
 import Gargantext.Core.Text.List.Group.WithStem ({-StopSize(..),-} GroupParams(..))
 import Gargantext.Core.Text.Corpus.Parsers (parseFile, FileFormat)
 import Gargantext.Core.Text.List (buildNgramsLists)
+import Gargantext.Core.Text.List.Social (FlowSocialListWith)
 import Gargantext.Core.Text.Terms
 import Gargantext.Core.Text.Terms.Mono.Stem.En (stemIt)
 import Gargantext.Core.Types (POS(NP))
@@ -151,11 +152,12 @@ flowDataText :: ( FlowCmdM env err m
                 -> DataText
                 -> TermType Lang
                 -> CorpusId
+                -> Maybe FlowSocialListWith
                 -> m CorpusId
-flowDataText u (DataOld ids) tt cid = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids
+flowDataText u (DataOld ids) tt cid mfslw = flowCorpusUser (_tt_lang tt) u (Right [cid]) corpusType ids mfslw
   where
     corpusType = (Nothing :: Maybe HyperdataCorpus)
-flowDataText u (DataNew txt) tt cid = flowCorpus u (Right [cid]) tt txt
+flowDataText u (DataNew txt) tt cid mfslw = flowCorpus u (Right [cid]) tt mfslw txt
 
 ------------------------------------------------------------------------
 -- TODO use proxy
@@ -167,7 +169,7 @@ flowAnnuaire :: (FlowCmdM env err m)
              -> m AnnuaireId
 flowAnnuaire u n l filePath = do
   docs <- liftBase $ (( splitEvery 500 <$> readFile_Annuaire filePath) :: IO [[HyperdataContact]])
-  flow (Nothing :: Maybe HyperdataAnnuaire) u n l docs
+  flow (Nothing :: Maybe HyperdataAnnuaire) u n l Nothing docs
 
 ------------------------------------------------------------------------
 flowCorpusFile :: (FlowCmdM env err m)
@@ -175,13 +177,14 @@ flowCorpusFile :: (FlowCmdM env err m)
            -> Either CorpusName [CorpusId]
            -> Limit -- Limit the number of docs (for dev purpose)
            -> TermType Lang -> FileFormat -> FilePath
+           -> Maybe FlowSocialListWith
            -> m CorpusId
-flowCorpusFile u n l la ff fp = do
+flowCorpusFile u n l la ff fp mfslw = do
   eParsed <- liftBase $ parseFile ff fp
   case eParsed of
     Right parsed -> do
       let docs = splitEvery 500 $ take l parsed
-      flowCorpus u n la (map (map toHyperdataDocument) docs)
+      flowCorpus u n la mfslw (map (map toHyperdataDocument) docs)
     Left e       -> panic $ "Error: " <> (T.pack e)
 
 ------------------------------------------------------------------------
@@ -191,6 +194,7 @@ flowCorpus :: (FlowCmdM env err m, FlowCorpus a)
            => User
            -> Either CorpusName [CorpusId]
            -> TermType Lang
+           -> Maybe FlowSocialListWith
            -> [[a]]
            -> m CorpusId
 flowCorpus = flow (Nothing :: Maybe HyperdataCorpus)
@@ -204,12 +208,13 @@ flow :: ( FlowCmdM env err m
         -> User
         -> Either CorpusName [CorpusId]
         -> TermType Lang
+        -> Maybe FlowSocialListWith
         -> [[a]]
         -> m CorpusId
-flow c u cn la docs = do
+flow c u cn la mfslw docs = do
   -- TODO if public insertMasterDocs else insertUserDocs
   ids <- traverse (insertMasterDocs c la) docs
-  flowCorpusUser (la ^. tt_lang) u cn c (concat ids)
+  flowCorpusUser (la ^. tt_lang) u cn c (concat ids) mfslw
 
 ------------------------------------------------------------------------
 flowCorpusUser :: ( FlowCmdM env err m
@@ -220,8 +225,9 @@ flowCorpusUser :: ( FlowCmdM env err m
                -> Either CorpusName [CorpusId]
                -> Maybe c
                -> [NodeId]
+               -> Maybe FlowSocialListWith
                -> m CorpusId
-flowCorpusUser l user corpusName ctype ids = do
+flowCorpusUser l user corpusName ctype ids mfslw = do
   -- User Flow
   (userId, _rootId, userCorpusId) <- getOrMk_RootWithCorpus user corpusName ctype
   -- NodeTexts is first
@@ -242,7 +248,7 @@ flowCorpusUser l user corpusName ctype ids = do
 
   --let gp = (GroupParams l 2 3 (StopSize 3)) 
   let gp = GroupWithPosTag l CoreNLP HashMap.empty 
-  ngs         <- buildNgramsLists gp user userCorpusId masterCorpusId
+  ngs         <- buildNgramsLists user userCorpusId masterCorpusId mfslw gp
 
   _userListId <- flowList_DbRepo listId ngs
   _mastListId <- getOrMkList masterCorpusId masterUserId