[FIX] merge with current dev

src/Gargantext/API/Ngrams.hs

@@ -27,14 +27,14 @@ module Gargantext.API.Ngrams
   ( TableNgramsApi
   , TableNgramsApiGet
   , TableNgramsApiPut
-  , TableNgramsApiPost
+  -- , TableNgramsApiPost
 
   , getTableNgrams
   , setListNgrams
-  , rmListNgrams
+  --, rmListNgrams TODO fix before exporting
   , putListNgrams
-  , putListNgrams'
-  , tableNgramsPost
+  --, putListNgrams'
+  --, tableNgramsPost
   , apiNgramsTableCorpus
   , apiNgramsTableDoc
 
@@ -100,7 +100,7 @@ import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson hiding ((.=))
 import Data.Aeson.TH (deriveJSON)
 import qualified Data.Aeson.Text as DAT
-import Data.Either (Either(Left))
+import Data.Either (Either(..))
 import Data.Foldable
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import qualified Data.List as List
@@ -110,7 +110,9 @@ import qualified Data.Map.Strict.Patch as PM
 import Data.Maybe (fromMaybe)
 import Data.Monoid
 import Data.Ord (Down(..))
-import Data.Patch.Class (Replace, replace, Action(act), Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, ours)
+import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..),
+                         PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, ours,
+                         MaybePatch(Mod), unMod, old, new)
 import Data.Set (Set)
 import qualified Data.Set as S
 import qualified Data.Set as Set
@@ -126,7 +128,7 @@ import Servant hiding (Patch)
 import System.Clock (getTime, TimeSpec, Clock(..))
 import System.FileLock (FileLock)
 import System.IO (stderr)
-import Test.QuickCheck (elements)
+import Test.QuickCheck (elements, frequency)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 
 import Prelude (error)
@@ -455,7 +457,7 @@ type PatchMap = PM.PatchMap
 
 
 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
-  deriving (Eq, Show, Generic, Validity, Semigroup, Monoid,
+  deriving (Eq, Show, Generic, Validity, Semigroup, Monoid, Group,
             Transformable, Composable)
 
 type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
@@ -519,9 +521,12 @@ instance ToSchema a => ToSchema (Replace a) where
             & required .~ [ "old", "new" ]
 
 data NgramsPatch =
-     NgramsPatch { _patch_children :: PatchMSet NgramsTerm
+     NgramsMod { _patch_children :: PatchMSet NgramsTerm
                , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
                }
+   | NgramsRpl { _patch_old :: Maybe NgramsRepoElement
+               , _patch_new :: Maybe NgramsRepoElement
+               }
       deriving (Eq, Show, Generic)
 
 deriveJSON (unPrefix "_") ''NgramsPatch
@@ -531,16 +536,31 @@ instance ToSchema  NgramsPatch where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
 
 instance Arbitrary NgramsPatch where
-  arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
+  arbitrary = frequency [ (9, NgramsMod <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
+                        , (1, NgramsRpl <$> arbitrary <*> arbitrary)
+                        ]
 
 instance Serialise NgramsPatch
 instance Serialise (Replace ListType)
+
 instance Serialise ListType
 
-type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType)
+type NgramsPatchIso =
+  MaybePatch NgramsRepoElement (PairPatch (PatchMSet NgramsTerm) (Replace ListType))
+  -- MaybePatch (MSet NgramsTerm, ListType) (PairPatch (PatchMSet NgramsTerm) (Replace ListType))
 
 _NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
-_NgramsPatch = iso (\(NgramsPatch c l) -> c :*: l) (\(c :*: l) -> NgramsPatch c l)
+_NgramsPatch = iso unwrap wrap
+  where
+    unwrap (NgramsMod c l) = Mod $ PairPatch (c, l)
+    unwrap (NgramsRpl o n) = replace o n
+    wrap x =
+      case unMod x of
+        Just (PairPatch (c, l)) -> NgramsMod c l
+        Nothing -> NgramsRpl (x ^? old . _Just) (x ^? new . _Just)
+
+_NgramsRepoElement :: Iso' NgramsRepoElement (MSet NgramsTerm, ListType)
+_NgramsRepoElement = undefined -- TODO
 
 instance Semigroup NgramsPatch where
   p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
@@ -561,28 +581,67 @@ instance Transformable NgramsPatch where
       (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
 
 type ConflictResolutionNgramsPatch =
-  ( ConflictResolutionPatchMSet NgramsTerm
+  ( ConflictResolutionReplace (Maybe NgramsRepoElement)
+  , ( ConflictResolutionPatchMSet NgramsTerm
     , ConflictResolutionReplace ListType
     )
+  , (Bool, Bool)
+  )
 type instance ConflictResolution NgramsPatch =
   ConflictResolutionNgramsPatch
 
-type PatchedNgramsPatch = (Set NgramsTerm, ListType)
+type PatchedNgramsPatch = Maybe NgramsRepoElement
   -- ~ Patched NgramsPatchIso
 type instance Patched NgramsPatch = PatchedNgramsPatch
 
+{-
+instance Applicable NgramsPatch NgramsRepoElement where
+  applicable (NgramsRpl o _) nre =
+    check (o == Just nre) "NgramsPatch: Applying a value different than the *old* value of a Rpl patch"
+  applicable (NgramsMod c l) nre =
+    applicable c (nre ^. nre_children) <>
+    applicable l (nre ^. nre_list)
+
+instance Action NgramsPatch NgramsRepoElement where
+  act (NgramsMod c l) m = act' <$> m
+    where
+      act' = (nre_children %~ act c)
+           . (nre_list     %~ act l)
+  act (NgramsRpl _ n) _ = n
+-}
+instance Applicable (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
+  applicable (PairPatch (c, l)) n = applicable c (n ^. nre_children) <> applicable l (n ^. nre_list)
+
+instance Action (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
+  act (PairPatch (c, l)) = (nre_children %~ act c)
+                         . (nre_list     %~ act l)
+
+--instance Applicable (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) (Maybe NgramsRepoElement) where
+--  applicable = _H
+
+instance Applicable NgramsPatchIso (Maybe (MSet NgramsTerm, ListType)) where
+  applicable p n = applicable p (n ^? _Just . from _NgramsRepoElement)
+
 instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
+  applicable p n = applicable (p ^. _NgramsPatch) (n ^? _Just . _NgramsRepoElement)
+  {-
+  applicable (NgramsRpl o _) nre =
+    check (o == Just nre) "NgramsPatch: Applying a value different than the *old* value of a Rpl patch"
   applicable p Nothing   = check (p == mempty) "NgramsPatch should be empty here"
   applicable p (Just nre) =
     applicable (p ^. patch_children) (nre ^. nre_children) <>
     applicable (p ^. patch_list)     (nre ^. nre_list)
-
-instance Action NgramsPatch NgramsRepoElement where
-  act p = (nre_children %~ act (p ^. patch_children))
-        . (nre_list     %~ act (p ^. patch_list))
+  -}
 
 instance Action NgramsPatch (Maybe NgramsRepoElement) where
-  act = fmap . act
+  act p m = act (p ^. _NgramsPatch) m
+  {-
+  act (NgramsMod c l) m = act' <$> m
+    where
+      act' = (nre_children %~ act c)
+           . (nre_list     %~ act l)
+  act (NgramsRpl _ n) _ = n
+  -}
 
 newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
   deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
@@ -821,7 +880,10 @@ ngramsStatePatchConflictResolution
   -> NgramsTerm
   -> ConflictResolutionNgramsPatch
 ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
-  = (const ours, ours)
+  = (ours, (const ours, ours), (False, False))
+                             -- ^------^------- they mean that Mod has always priority.
+                             --(True, False) <- would mean priority to the left (same as ours).
+
   -- undefined {- TODO think this through -}, listTypeConflictResolution)
 
 -- Current state:
@@ -865,6 +927,7 @@ addListNgrams listId ngramsType nes = do
     m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
 -}
 
+-- UNSAFE
 rmListNgrams ::  RepoCmdM env err m
               => ListId
               -> TableNgrams.NgramsType
@@ -873,6 +936,7 @@ rmListNgrams l nt = setListNgrams l nt mempty
 
 -- | TODO: incr the Version number
 -- && should use patch
+-- UNSAFE
 setListNgrams ::  RepoCmdM env err m
               => NodeId
               -> TableNgrams.NgramsType
@@ -890,10 +954,12 @@ setListNgrams listId ngramsType ns = do
            )
   saveRepo
 
-
+-- NOTE
+-- This is no longer part of the API.
+-- This function is maintained for its usage in Database.Action.Flow.List.
 -- If the given list of ngrams elements contains ngrams already in
 -- the repo, they will be ignored.
-putListNgrams :: RepoCmdM env err m
+putListNgrams :: (HasInvalidError err, RepoCmdM env err m)
               => NodeId
               -> TableNgrams.NgramsType
               -> [NgramsElement] -> m ()
@@ -902,19 +968,27 @@ putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
   where
     m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
 
-putListNgrams' :: RepoCmdM env err m
+putListNgrams' :: (HasInvalidError err, RepoCmdM env err m)
                => NodeId
                -> TableNgrams.NgramsType
                -> Map NgramsTerm NgramsRepoElement
                -> m ()
 putListNgrams' nodeId ngramsType ns = do
-  -- printDebug "[putLictNgrams'] nodeId" nodeId
-  -- printDebug "[putLictNgrams'] ngramsType" ngramsType
-  -- printDebug "[putListNgrams'] ns" ns
+  printDebug "[putLictNgrams'] nodeId" nodeId
+  printDebug "[putLictNgrams'] ngramsType" ngramsType
+  printDebug "[putListNgrams'] ns" ns
+--  commitStatePatch ()
+
+  let p1 = NgramsTablePatch . PM.fromMap $ NgramsRpl Nothing . Just <$> ns
+      (p0, p0_validity) = PM.singleton nodeId p1
+      (p, p_validity) = PM.singleton ngramsType p0
+  -- assertValid p1_validity
+  assertValid p0_validity
+  assertValid p_validity
   var <- view repoVar
   liftBase $ modifyMVar_ var $ \r -> do
     pure $ r & r_version +~ 1
-             & r_history %~ (mempty :)
+             & r_history %~ (p :)
              & r_state . at ngramsType %~
                (Just .
                  (at nodeId %~
@@ -928,6 +1002,7 @@ putListNgrams' nodeId ngramsType ns = do
   saveRepo
 
 
+{-
 -- TODO-ACCESS check
 tableNgramsPost :: RepoCmdM env err m
                 => TabType
@@ -936,6 +1011,7 @@ tableNgramsPost :: RepoCmdM env err m
                 -> [NgramsTerm] -> m ()
 tableNgramsPost tabType nodeId mayList =
   putListNgrams nodeId (ngramsTypeFromTabType tabType) . fmap (newNgramsElement mayList)
+-}
 
 currentVersion :: RepoCmdM env err m
                => m Version
@@ -944,6 +1020,34 @@ currentVersion = do
   r   <- liftBase $ readMVar var
   pure $ r ^. r_version
 
+
+-- tableNgramsPut :: (HasInvalidError err, RepoCmdM env err m)
+commitStatePatch :: RepoCmdM env err m => Versioned NgramsStatePatch -> m (Versioned NgramsStatePatch)
+commitStatePatch (Versioned p_version p) = do
+  var <- view repoVar
+  vq' <- liftBase $ modifyMVar var $ \r -> do
+    let
+      q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
+      (p', q') = transformWith ngramsStatePatchConflictResolution p q
+      r' = r & r_version +~ 1
+              & r_state   %~ act p'
+              & r_history %~ (p' :)
+    {-
+    -- Ideally we would like to check these properties. However:
+    -- * They should be checked only to debug the code. The client data
+    --   should be able to trigger these.
+    -- * What kind of error should they throw (we are in IO here)?
+    -- * Should we keep modifyMVar?
+    -- * Should we throw the validation in an Exception, catch it around
+    --   modifyMVar and throw it back as an Error?
+    assertValid $ transformable p q
+    assertValid $ applicable p' (r ^. r_state)
+    -}
+    pure (r', Versioned (r' ^. r_version) q')
+
+  saveRepo
+  pure vq'
+
 tableNgramsPull :: RepoCmdM env err m
                 => ListId
                 -> TableNgrams.NgramsType
@@ -979,30 +1083,8 @@ tableNgramsPut tabType listId (Versioned p_version p_table)
       assertValid p0_validity
       assertValid p_validity
 
-      var <- view repoVar
-      vq' <- liftBase $ modifyMVar var $ \r -> do
-        let
-          q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
-          (p', q') = transformWith ngramsStatePatchConflictResolution p q
-          r' = r & r_version +~ 1
-                 & r_state   %~ act p'
-                 & r_history %~ (p' :)
-          q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
-        {-
-        -- Ideally we would like to check these properties. However:
-        -- * They should be checked only to debug the code. The client data
-        --   should be able to trigger these.
-        -- * What kind of error should they throw (we are in IO here)?
-        -- * Should we keep modifyMVar?
-        -- * Should we throw the validation in an Exception, catch it around
-        --   modifyMVar and throw it back as an Error?
-        assertValid $ transformable p q
-        assertValid $ applicable p' (r ^. r_state)
-        -}
-        pure (r', Versioned (r' ^. r_version) q'_table)
-
-      saveRepo
-      pure vq'
+      commitStatePatch (Versioned p_version p)
+        <&> v_data %~ (view (_PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just))
 
 mergeNgramsElement :: NgramsRepoElement -> NgramsRepoElement -> NgramsRepoElement
 mergeNgramsElement _neOld neNew = neNew
@@ -1221,12 +1303,14 @@ type TableNgramsApiPut = Summary " Table Ngrams API Change"
                        :> ReqBody '[JSON] (Versioned NgramsTablePatch)
                        :> Put     '[JSON] (Versioned NgramsTablePatch)
 
+{-
 type TableNgramsApiPost = Summary " Table Ngrams API Adds new ngrams"
                        :> QueryParamR "ngramsType" TabType
                        :> QueryParamR "list"       ListId
                        :> QueryParam  "listType"   ListType
                        :> ReqBody '[JSON] [NgramsTerm]
                        :> Post    '[JSON] ()
+-}
 
 type RecomputeScoresNgramsApiGet = Summary " Recompute scores for ngrams table"
                        :> QueryParamR "ngramsType"  TabType
@@ -1240,7 +1324,7 @@ type TableNgramsApiGetVersion = Summary " Table Ngrams API Get Version"
 
 type TableNgramsApi =  TableNgramsApiGet
                   :<|> TableNgramsApiPut
-                  :<|> TableNgramsApiPost
+                  -- :<|> TableNgramsApiPost
                   :<|> RecomputeScoresNgramsApiGet
                   :<|> "version" :> TableNgramsApiGetVersion
 
@@ -1297,7 +1381,7 @@ apiNgramsTableCorpus :: ( RepoCmdM env err m
                      => NodeId -> ServerT TableNgramsApi m
 apiNgramsTableCorpus cId =  getTableNgramsCorpus cId
                        :<|> tableNgramsPut
-                       :<|> tableNgramsPost
+                       -- :<|> tableNgramsPost
                        :<|> scoresRecomputeTableNgrams cId
                        :<|> getTableNgramsVersion cId
 
@@ -1310,7 +1394,7 @@ apiNgramsTableDoc :: ( RepoCmdM env err m
                   => DocId -> ServerT TableNgramsApi m
 apiNgramsTableDoc dId =  getTableNgramsDoc dId
                     :<|> tableNgramsPut
-                    :<|> tableNgramsPost
+                    -- :<|> tableNgramsPost
                     :<|> scoresRecomputeTableNgrams dId
                     :<|> getTableNgramsVersion dId
                     -- > add new ngrams in database (TODO AD)

src/Gargantext/API/Ngrams/List.hs

@@ -74,6 +74,7 @@ get' lId = fromList
 
 ------------------------------------------------------------------------
 -- TODO : purge list
+-- TODO talk
 post :: FlowCmdM env err m
     => ListId
     -> NgramsList

src/Gargantext/Database/Action/Flow/Types.hs

@@ -20,6 +20,7 @@ module Gargantext.Database.Action.Flow.Types
     where
 
 import Data.Aeson (ToJSON)
+import Gargantext.Core.Types (HasInvalidError)
 import Gargantext.Core.Flow.Types
 import Gargantext.Core.Text
 import Gargantext.Core.Text.Terms
@@ -32,6 +33,7 @@ type FlowCmdM env err m =
   ( CmdM     env err m
   , RepoCmdM env err m
   , HasNodeError err
+  , HasInvalidError err
   , HasRepoVar env
   )
 

stack.yaml

@@ -3,6 +3,8 @@ flags: {}
 extra-package-dbs: []
 packages:
 - .
+- 'deps/patches-class'
+- 'deps/patches-map'
 #- 'deps/servant-job'
 #- 'deps/clustering-louvain'
 
@@ -42,16 +44,16 @@ extra-deps:
 - git: https://gitlab.iscpif.fr/gargantext/crawlers/isidore.git
   commit: 3db385e767d2100d8abe900833c6e7de3ac55e1b
     #
-- git: https://gitlab.iscpif.fr/gargantext/patches-class
-  commit: 746b4ce0af8f9e600d555ad7e5b2973a940cdad9
+#- git: https://gitlab.iscpif.fr/gargantext/patches-class
+#  commit: 746b4ce0af8f9e600d555ad7e5b2973a940cdad9
   #- git: https://github.com/delanoe/servant-job.git
   #commit: 7a7b7100e6d132adb4c11b25b2128e6309690ac0
 - git: https://github.com/np/servant-job.git
   commit: 6487744c322baaa9229fdabd321a878a5b363c61
 - git: https://gitlab.iscpif.fr/gargantext/clustering-louvain.git
   commit: 7d74f96dfea8e51fbab1793cc0429b2fe741f73d
-- git: https://github.com/np/patches-map
-  commit: 8c6f38c4844ead53e664cf9c82ba461715dbe445
+#- git: https://github.com/np/patches-map
+#  commit: 8c6f38c4844ead53e664cf9c82ba461715dbe445
 - git: https://github.com/delanoe/haskell-opaleye.git  #- opaleye-0.6.7002.0
   commit: 63ee65d974e9d20eaaf17a2e83652175988cbb79
 - git: https://github.com/delanoe/hsparql.git