[NGRAMS-REPO] no longer rely on merging master & user lists

src/Gargantext/API/Ngrams.hs

@@ -54,7 +54,7 @@ import Data.Map.Strict (Map)
 --import qualified Data.Set as Set
 import Control.Category ((>>>))
 import Control.Concurrent
-import Control.Lens (makeLenses, makePrisms, Getter, Prism', prism', Iso', iso, from, (^..), (.~), (#), to, {-withIndex, folded, ifolded,-} view, (^.), (+~), (%~), at, _Just, Each(..), itraverse_, (.=), both, mapped)
+import Control.Lens (makeLenses, makePrisms, Getter, Prism', prism', Iso', iso, from, (^..), (.~), (#), to, {-withIndex, folded, ifolded,-} view, (^.), (+~), (<>~), (%~), at, _Just, Each(..), itraverse_, (.=), both, mapped)
 import Control.Monad (guard)
 import Control.Monad.Error.Class (MonadError, throwError)
 import Control.Monad.Reader
@@ -646,28 +646,60 @@ instance HasInvalidError ServantErr where
       make _ = err
       match e = guard (e == err) $> UnsupportedVersion-}
 
-assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
-assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
+-- assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
+-- assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
+
+assertValid :: MonadIO m => Validation -> m ()
+assertValid v = when (not $ validationIsValid v) $ fail $ show v
 
 -- Current state:
 --   Insertions are not considered as patches,
 --   they do not extend history,
 --   they do not bump version.
-insertNewOnly :: a -> Maybe a -> Maybe a
-insertNewOnly a = maybe (Just a) (const $ error "insertNewOnly: impossible")
+insertNewOnly :: a -> Maybe b -> a
+insertNewOnly m = maybe m (const $ error "insertNewOnly: impossible")
   -- TODO error handling
 
 something :: Monoid a => Maybe a -> a
 something Nothing  = mempty
 something (Just a) = a
 
+{- unused
+-- TODO refactor with putListNgrams
+copyListNgrams :: RepoCmdM env err m
+               => NodeId -> NodeId -> NgramsType
+               -> m ()
+copyListNgrams srcListId dstListId ngramsType = do
+  var <- view repoVar
+  liftIO $ modifyMVar_ var $
+    pure . (r_state . at ngramsType %~ (Just . f . something))
+  saveRepo
+  where
+    f :: Map NodeId NgramsTableMap -> Map NodeId NgramsTableMap
+    f m = m & at dstListId %~ insertNewOnly (m ^. at srcListId)
+-}
+
+-- TODO refactor with putListNgrams
+-- The list must be non-empty!
+-- The added ngrams must be non-existent!
+addListNgrams :: RepoCmdM env err m
+              => NodeId -> NgramsType
+              -> [NgramsElement] -> m ()
+addListNgrams listId ngramsType nes = do
+  var <- view repoVar
+  liftIO $ modifyMVar_ var $
+    pure . (r_state . at ngramsType . _Just . at listId . _Just <>~ m)
+  saveRepo
+  where
+    m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
+
 putListNgrams :: RepoCmdM env err m
               => NodeId -> NgramsType
               -> [NgramsElement] -> m ()
 putListNgrams listId ngramsType nes = do
   var <- view repoVar
   liftIO $ modifyMVar_ var $
-    pure . (r_state . at ngramsType %~ (Just . (at listId %~ insertNewOnly m) . something))
+    pure . (r_state . at ngramsType %~ (Just . (at listId %~ insertNewOnly (Just m)) . something))
   saveRepo
   where
     m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
@@ -691,7 +723,7 @@ tableNgramsPatch _corpusId maybeTabType listId (Versioned p_version p_table) = d
   assertValid p_validity
 
   var <- view repoVar
-  (p'_applicable, vq') <- liftIO $ modifyMVar var $ \r ->
+  vq' <- liftIO $ modifyMVar var $ \r -> do
     let
       q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
       (p', q') = transformWith ngramsStatePatchConflictResolution p q
@@ -699,12 +731,11 @@ tableNgramsPatch _corpusId maybeTabType listId (Versioned p_version p_table) = d
              & r_state   %~ act p'
              & r_history %~ (p' :)
       q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
-      p'_applicable = applicable p' (r ^. r_state)
-    in
-    pure (r', (p'_applicable, Versioned (r' ^. r_version) q'_table))
+    assertValid $ transformable p q
+    assertValid $ applicable p' (r ^. r_state)
+    pure (r', Versioned (r' ^. r_version) q'_table)
 
   saveRepo
-  assertValid p'_applicable
   pure vq'
 
   {- DB version

src/Gargantext/Database/Flow.hs

@@ -59,7 +59,7 @@ import Gargantext.Text.Parsers (parseDocs, FileFormat)
 import System.FilePath (FilePath)
 import Gargantext.API.Ngrams (HasRepoVar)
 import Servant (ServantErr)
-import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams, RepoCmdM)
+import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams, addListNgrams, RepoCmdM)
 --import Gargantext.Database.Schema.User (insertUsers, simpleUser, gargantuaUser)
 import qualified Data.Map as DM
 
@@ -121,8 +121,9 @@ flowCorpus' NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, user
   _             <- insertToNodeNgrams indexedNgrams
 
   -- List Ngrams Flow
-  _masterListId <- flowList masterUserId masterCorpusId indexedNgrams
-  _userListId   <- flowListUser userId userCorpusId 100
+  let ngs = ngrams2list' indexedNgrams
+  _masterListId <- flowList masterUserId masterCorpusId ngs
+  _userListId   <- flowListUser userId userCorpusId ngs 100
 --------------------------------------------------
   _ <- mkDashboard userCorpusId userId
   _ <- mkGraph     userCorpusId userId
@@ -242,8 +243,13 @@ mapNodeIdNgrams = DM.unionsWith (DM.unionWith (DM.unionWith (+))) . fmap f
         nId = documentId $ documentWithId d
 
 ------------------------------------------------------------------------
+flowListBase :: FlowCmdM env err m => ListId -> Map NgramsType [NgramsElement] -> m ()
+flowListBase lId ngs = do
+-- compute Candidate / Map
+  mapM_ (\(typeList, ngElmts) -> putListNgrams lId typeList ngElmts) $ toList ngs
+
 flowList :: FlowCmdM env err m => UserId -> CorpusId
-         -> Map NgramsIndexed (Map NgramsType (Map NodeId Int))
+         -> Map NgramsType [NgramsElement]
          -> m ListId
 flowList uId cId ngs = do
   --printDebug "ngs:" ngs
@@ -255,20 +261,20 @@ flowList uId cId ngs = do
   -- let groupEd = groupNgramsBy (\(NgramsT t1 n1) (NgramsT t2 n2) -> if (((==) t1 t2) && ((==) n1 n2)) then (Just (n1,n2)) else Nothing) ngs
   -- _ <- insertGroups lId groupEd
 
--- compute Candidate / Map
-  mapM_ (\(typeList, ngElmts) -> putListNgrams lId typeList ngElmts) $ toList $ ngrams2list' ngs
+  flowListBase lId ngs
 
   pure lId
 
 flowListUser :: FlowCmdM env err m
-             => UserId -> CorpusId -> Int -> m ListId
-flowListUser uId cId n = do
+             => UserId -> CorpusId -> Map NgramsType [NgramsElement] -> Int -> m ListId
+flowListUser uId cId ngsM n = do
   lId <- getOrMkList cId uId
 
   ngs <- take n <$> sortWith tficf_score
                 <$> getTficf userMaster cId lId NgramsTerms
 
-  putListNgrams lId NgramsTerms $
+  flowListBase lId ngsM
+  addListNgrams lId NgramsTerms $
     [ NgramsElement (tficf_ngramsTerms ng) GraphList 1 Nothing mempty
     | ng <- ngs 
     ]