Merge remote-tracking branch 'origin/adinapoli/issue-217' into dev

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

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

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

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