diff --git a/gargantext.cabal b/gargantext.cabal
index 2c39bbc1d178cb60aee290b3643fcb5edd237495..56153b3e93b0c0e8edb26a1eaef983eb7fd72c9f 100644
--- a/gargantext.cabal
+++ b/gargantext.cabal
@@ -902,12 +902,15 @@ test-suite garg-test
, gargantext-prelude
, hspec
, parsec
+ , patches-class
+ , patches-map
, quickcheck-instances
, tasty
, tasty-hunit
, text
, time
, unordered-containers
+ , validity
default-language: Haskell2010
test-suite jobqueue-test
diff --git a/package.yaml b/package.yaml
index 000aa97821a20eedc3065ce96bf86199943d8ccb..ec57bcb1f8bffb51a95684efe0e949c74054a42c 100644
--- a/package.yaml
+++ b/package.yaml
@@ -523,11 +523,14 @@ tests:
- quickcheck-instances
- time
- parsec
+ - patches-class
+ - patches-map
- duckling
- tasty
- tasty-hunit
- text
- unordered-containers
+ - validity
jobqueue-test:
main: Main.hs
source-dirs: tests/queue
diff --git a/src-test/Ngrams/Query.hs b/src-test/Ngrams/Query.hs
index 75d842f83cb652dafd5088526768f1ce38060520..47a3971a838981f6632230d3205590d810584e5a 100644
--- a/src-test/Ngrams/Query.hs
+++ b/src-test/Ngrams/Query.hs
@@ -3,16 +3,18 @@
module Ngrams.Query where
import Control.Monad
-import Gargantext.Prelude
-import Gargantext.API.Ngrams
-import Gargantext.API.Ngrams.Types
import Data.Coerce
-import Data.Monoid
-import qualified Data.Text as T
-import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
-import Gargantext.Core.Types.Query
+import Data.Monoid
+import Gargantext.API.Ngrams
+import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types.Main
+import Gargantext.Core.Types.Query
+import Gargantext.Prelude
+import qualified Data.Map.Strict as Map
+import qualified Data.Patch.Class as Patch
+import qualified Data.Validity as Validity
+import qualified Data.Text as T
import Ngrams.Query.PaginationCorpus
import Test.Tasty
@@ -61,6 +63,8 @@ unitTests = testGroup "Query tests"
, testCase "Simple pagination on CandidateTerm (limit < total terms)" test_pagination04
, testCase "paginating QuantumComputing corpus works (MapTerms)" test_paginationQuantum
, testCase "paginating QuantumComputing corpus works (CandidateTerm)" test_paginationQuantum_02
+ -- -- Patching
+ , testCase "I can apply a patch to term mapTerms to stopTerms (issue #217)" test_217
]
-- Let's test that if we request elements sorted in
@@ -297,3 +301,32 @@ test_paginationQuantum_02 = do
, _nsq_orderBy = Nothing
, _nsq_searchQuery = mockQueryFn Nothing
}
+
+issue217Corpus :: NgramsTableMap
+issue217Corpus = Map.fromList [
+ ( "advantages", NgramsRepoElement 1 MapTerm Nothing Nothing (mSetFromList ["advantage"]))
+ , ( "advantage" , NgramsRepoElement 1 MapTerm (Just "advantages") (Just "advantages") mempty)
+ ]
+
+patched217Corpus :: NgramsTableMap
+patched217Corpus = Map.fromList [
+ ( "advantages", NgramsRepoElement 1 StopTerm Nothing Nothing (mSetFromList ["advantage"]))
+ , ( "advantage" , NgramsRepoElement 1 StopTerm (Just "advantages") (Just "advantages") mempty)
+ ]
+
+-- In this patch we simulate turning the subtree composed by 'advantages' and 'advantage'
+-- from map terms to stop terms.
+patch217 :: NgramsTablePatch
+patch217 = mkNgramsTablePatch $ Map.fromList [
+ (NgramsTerm "advantages", NgramsPatch
+ { _patch_children = mempty
+ , _patch_list = Patch.Replace MapTerm StopTerm
+ }
+ )
+ ]
+
+test_217 :: Assertion
+test_217 = do
+ -- Check the patch is applicable
+ Validity.validationIsValid (Patch.applicable patch217 (Just issue217Corpus)) @?= True
+ Patch.act patch217 (Just issue217Corpus) @?= Just patched217Corpus
diff --git a/src/Gargantext/API/Ngrams/Types.hs b/src/Gargantext/API/Ngrams/Types.hs
index 7543b3e19b2fb056b7a02d961b84d6b1f6e84871..3f42a4b7ed242aedd7e2f225fe51753a2905d237 100644
--- a/src/Gargantext/API/Ngrams/Types.hs
+++ b/src/Gargantext/API/Ngrams/Types.hs
@@ -20,7 +20,7 @@ module Gargantext.API.Ngrams.Types where
import Codec.Serialise (Serialise())
import Control.Category ((>>>))
import Control.DeepSeq (NFData)
-import Control.Lens (makeLenses, makePrisms, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~))
+import Control.Lens (makeLenses, makePrisms, Iso', iso, from, (.~), (.=), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~), over)
import Control.Monad.State
import Data.Aeson hiding ((.=))
import Data.Aeson.TH (deriveJSON)
@@ -552,9 +552,16 @@ instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
instance Action NgramsPatch (Maybe NgramsRepoElement) where
act p = act (p ^. _NgramsPatch)
+instance Action (Replace ListType) NgramsRepoElement where
+ -- Rely on the already-defined instance 'Action (Replace a) a'.
+ act replaceP = over nre_list (act replaceP)
+
newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
+mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch
+mkNgramsTablePatch = NgramsTablePatch . PM.fromMap
+
instance Serialise NgramsTablePatch
instance Serialise (PatchMap NgramsTerm NgramsPatch)
@@ -627,34 +634,59 @@ ngramsElementFromRepo
-}
}
-reRootChildren :: NgramsTerm -> ReParent NgramsTerm
+reRootChildren :: NgramsTerm -> NgramsTerm -> State NgramsTableMap ()
reRootChildren root ngram = do
nre <- use $ at ngram
forOf_ (_Just . nre_children . folded) nre $ \child -> do
at child . _Just . nre_root ?= root
reRootChildren root child
-reParent :: Maybe RootParent -> ReParent NgramsTerm
+reParent :: Maybe RootParent -> NgramsTerm -> State NgramsTableMap ()
reParent rp child = do
at child . _Just %= ( (nre_parent .~ (_rp_parent <$> rp))
. (nre_root .~ (_rp_root <$> rp))
)
reRootChildren (fromMaybe child (rp ^? _Just . rp_root)) child
-reParentAddRem :: RootParent -> NgramsTerm -> ReParent AddRem
+reParentAddRem :: RootParent -> NgramsTerm -> AddRem -> State NgramsTableMap ()
reParentAddRem rp child p =
reParent (if isRem p then Nothing else Just rp) child
-reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
+-- | For each (k,v) of the 'PatchMap', transform the input 'NgramsTableMap'.
+reParentNgramsPatch :: NgramsTerm
+ -- ^ The 'k' which is the target of the transformation.
+ -> NgramsPatch
+ -- ^ The patch to be applied to 'k'.
+ -> State NgramsTableMap ()
reParentNgramsPatch parent ngramsPatch = do
root_of_parent <- use (at parent . _Just . nre_root)
+ children <- use (at parent . _Just . nre_children)
let
- root = fromMaybe parent root_of_parent
- rp = RootParent { _rp_root = root, _rp_parent = parent }
+ root = fromMaybe parent root_of_parent
+ rp = RootParent { _rp_root = root, _rp_parent = parent }
+
+ -- Apply whichever transformation has being applied to the parent also to its children.
+ -- This is /not/ the same as applying 'patch_children' as in the 'itraverse_' below,
+ -- because that modifies the tree by adding or removing children, and it will be triggered
+ -- only if we have a non-empty set for 'patch_children'.
+ forM_ children $ \childTerm -> do
+ child <- use (at childTerm)
+ case child of
+ Nothing -> pure ()
+ Just c
+ -- We don't need to check if the patch is applicable, because we would be calling
+ -- 'Applicable (Replace ListType) NgramsRepoElement' which is /always/ satisfied
+ -- being 'ListType' a field of 'NgramsRepoElement'.
+ | NgramsPatch{_patch_list} <- ngramsPatch
+ -> at childTerm . _Just .= act _patch_list c
+ | otherwise
+ -> pure () -- ignore the patch and carry on.
+
+ -- Finally, add or remove children according to the patch.
itraverse_ (reParentAddRem rp) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
-- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
-reParentNgramsTablePatch :: ReParent NgramsTablePatch
+reParentNgramsTablePatch :: NgramsTablePatch -> State NgramsTableMap ()
reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
-- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
@@ -672,8 +704,6 @@ instance Arbitrary NgramsTablePatch where
-- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
-- ntp_ngrams_patches = _NgramsTablePatch . undefined
-type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
-
------------------------------------------------------------------------
type Version = Int