[FIX] temp resolution of commitpatch

src/Gargantext/API/Ngrams.hs

@@ -204,9 +204,21 @@ ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
   = (ours, (const ours, ours), (False, False))
                              -- (False, False) mean here that Mod has always priority.
                              -- (True, False) <- would mean priority to the left (same as ours).
+  -- undefined {- TODO think this through -}, listTypeConflictResolution)
 
+ngramsStatePatchConflictResolution'
+  :: TableNgrams.NgramsType
+  -> NgramsTerm
+  -> ConflictResolutionNgramsPatch
+ngramsStatePatchConflictResolution' _ngramsType _ngramsTerm
+  = (ours, (const ours, ours), (False, False))
+                             -- (False, False) mean here that Mod has always priority.
+                             -- (True, False) <- would mean priority to the left (same as ours).
   -- undefined {- TODO think this through -}, listTypeConflictResolution)
 
+
+
+
 -- Current state:
 --   Insertions are not considered as patches,
 --   they do not extend history,
@@ -301,6 +313,16 @@ newNgramsFromNgramsStatePatch p =
   | (n,np) <- p ^.. _PatchMap . each . _PatchMap . each . _NgramsTablePatch . _PatchMap . ifolded . withIndex
   , _ <- np ^.. patch_new . _Just
   ]
+newNgramsFromNgramsStatePatch' :: NgramsStatePatch' -> [Ngrams]
+newNgramsFromNgramsStatePatch' p =
+  [ text2ngrams (unNgramsTerm n)
+  | (n,np) <- p ^.. _PatchMap
+                -- . each . _PatchMap
+                . each . _NgramsTablePatch
+                . _PatchMap . ifolded . withIndex
+  , _ <- np ^.. patch_new . _Just
+  ]
+
 
 -- tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
 commitStatePatch :: RepoCmdM env err m
@@ -335,6 +357,31 @@ commitStatePatch (Versioned p_version p) = do
 
   pure vq'
 
+commitStatePatch' :: HasNodeStory env err m
+                 => ListId
+                 ->    Versioned NgramsStatePatch'
+                 -> m (Versioned NgramsStatePatch')
+commitStatePatch' listId (Versioned p_version p) = do
+  var <- getRepoVar listId
+  vq' <- liftBase $ modifyMVar var $ \ns -> do
+    let
+      a = ns ^. unNodeStory . at listId . _Just
+      q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
+      (p', q') = transformWith ngramsStatePatchConflictResolution' p q
+      a' = a & a_version +~ 1
+             & a_state   %~ act p'
+             & a_history %~ (p' :)
+    pure ( ns & unNodeStory . at listId .~ (Just a')
+         , Versioned (a' ^. a_version) q'
+         )
+  saveRepo'
+  -- Save new ngrams
+  _ <- insertNgrams (newNgramsFromNgramsStatePatch' p)
+
+  pure $ vq'
+
+
+
 -- This is a special case of tableNgramsPut where the input patch is empty.
 tableNgramsPull :: RepoCmdM env err m
                 => ListId

src/Gargantext/API/Ngrams/Tools.hs

@@ -49,6 +49,12 @@ getRepo' listIds = do
     Nothing  -> panic "[G.A.N.Tools.getRepo']"
     Just nls -> pure nls 
 
+getRepoVar :: HasNodeStory env err m
+           => ListId -> m (MVar NodeListStory)
+getRepoVar l = do
+  f <- getNodeListStory
+  v  <- liftBase $ f l
+  pure v
 
 getNodeListStory :: HasNodeStory env err m
                  => m (NodeId -> IO (MVar NodeListStory))

src/Gargantext/API/Ngrams/Types.hs

@@ -532,6 +532,7 @@ instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTable
 type instance ConflictResolution NgramsTablePatch =
   NgramsTerm -> ConflictResolutionNgramsPatch
 
+
 type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
   -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
 type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
@@ -675,17 +676,13 @@ data Repo s p = Repo
   }
   deriving (Generic, Show)
 
-
-
 -- | TO REMOVE
 type NgramsRepo       = Repo     NgramsState NgramsStatePatch
-
 type NgramsState      = Map      TableNgrams.NgramsType (Map NodeId NgramsTableMap)
 type NgramsStatePatch = PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch)
 
 ----------------------------------------------------------------------
 
-
 instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
   parseJSON = genericParseJSON $ unPrefix "_r_"
 

src/Gargantext/Core/NodeStory.hs

@@ -26,6 +26,7 @@ import Data.Aeson hiding ((.=))
 import qualified Data.List as List
 import Data.Map as Map
 import Data.Monoid
+import Data.Semigroup
 import GHC.Generics (Generic)
 import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types (NodeId)
@@ -206,12 +207,18 @@ instance (Serialise s, Serialise p) => Serialise (Archive s p)
 -- TODO Semigroup instance for unions
 
 type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'
-type ArchiveList       = Archive NgramsState' NgramsStatePatch'
 
 type NgramsState'      = Map       TableNgrams.NgramsType NgramsTableMap
 type NgramsStatePatch' = PatchMap  TableNgrams.NgramsType NgramsTablePatch
 instance Serialise NgramsStatePatch'
 
+-- TODO check this
+instance (Semigroup s, Semigroup p) => Semigroup (Archive s p) where
+  (<>) (Archive _v _s p) (Archive v' s' p') = Archive v' s' (p' <> p)
+
+instance Monoid (Archive NgramsState' NgramsStatePatch') where
+  mempty = Archive 0 mempty []
+
 instance (FromJSON s, FromJSON p) => FromJSON (Archive s p) where
   parseJSON = genericParseJSON $ unPrefix "_a_"