Try to reproduce the hierarchical patching bug

src/Gargantext/API/Ngrams.hs

@@ -82,6 +82,11 @@ module Gargantext.API.Ngrams
 
   -- * Handlers to be used when serving top-level API requests
   , getTableNgramsCorpusHandler
+
+  -- * Internals, for testing
+  , compute_new_state_patches
+  , PatchHistory(..)
+  , newNgramsFromNgramsStatePatch
   )
   where
 
@@ -261,25 +266,11 @@ commitStatePatch :: NodeStoryEnv err
                  -> Versioned NgramsStatePatch'
                  -> DBUpdate err (Versioned NgramsStatePatch')
 commitStatePatch env listId (Versioned _p_version p) = do
-  -- printDebug "[commitStatePatch]" listId
   a <- getNodeStory env listId
   let archiveSaver = view hasNodeArchiveStoryImmediateSaver env
-  -- ns <- liftBase $ atomically $ readTVar var
-  let
-    -- a = ns ^. unNodeStory . at listId . non initArchive
-    -- apply patches from version p_version to a ^. a_version
-    -- TODO Check this
-    --q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
-    q = mconcat $ a ^. a_history
-
-  --printDebug "[commitStatePatch] transformWith" (p,q)
-  -- let tws s = case s of
-  --       (Mod p) -> "Mod"
-  --       _ -> "Rpl"
-  -- printDebug "[commitStatePatch] transformWith" (tws $ p ^. _NgramsPatch, tws $ q ^. _NgramsPatch)
 
   let
-    (p', q') = transformWith ngramsStatePatchConflictResolution p q
+    (p', q') = compute_new_state_patches p (PatchHistory $ a ^. a_history)
     a' = a & a_version +~ 1
            & a_state   %~ act p'
            & a_history %~ (p' :)
@@ -335,6 +326,27 @@ commitStatePatch env listId (Versioned _p_version p) = do
   pure newA
 
 
+newtype PatchHistory =
+  PatchHistory { _PatchHistory :: [ NgramsStatePatch' ] }
+  deriving (Show, Eq)
+
+-- | Computes the new state patch from the new patch and
+-- the history of patches applied up to this point.
+-- Returns a pair of patches (p,q) following the semantic of
+-- the 'Transformable' class, that says:
+--
+-- Given two diverging patches @p@ and @q@, @transformWith m p q@ returns
+-- a pair of updated patches @(p',q')@ such that @p' <> q@ and
+-- @q' <> p@ are equivalent patches that incorporate the changes
+-- of /both/ @p@ and @q@, up to merge conflicts, which are handled by
+-- the provided function @m@.
+compute_new_state_patches :: NgramsStatePatch'
+                          -> PatchHistory
+                          -> (NgramsStatePatch', NgramsStatePatch')
+compute_new_state_patches latest_patch (PatchHistory history) =
+  let squashed_history = mconcat history
+  in transformWith ngramsStatePatchConflictResolution latest_patch squashed_history
+
 
 -- This is a special case of tableNgramsPut where the input patch is empty.
 tableNgramsPull :: NodeStoryEnv err

test/Test/Offline/Ngrams.hs

@@ -3,20 +3,27 @@ module Test.Offline.Ngrams (tests) where
 
 import Prelude
 
+import Control.Lens
+import Data.Map.Strict qualified as Map
+import Data.Map.Strict.Patch qualified as PM
+import Data.Patch.Class (Replace(..))
 import Data.Text qualified as T
+import Gargantext.API.Ngrams.Types
 import Gargantext.API.Ngrams.Types qualified as NT
 import Gargantext.Core
+import Gargantext.Core.Text.Terms.Mono (isSep)
 import Gargantext.Core.Text.Terms.WithList
 import Gargantext.Core.Types
 import Gargantext.Database.Action.Flow.Utils (docNgrams)
-import Gargantext.Database.Schema.Context
 import Gargantext.Database.Admin.Types.Hyperdata
+import Gargantext.Database.Schema.Context
+import Test.Hspec
+import Test.HUnit
 import Test.Instances ()
 import Test.QuickCheck
-import Test.Hspec
-import Control.Lens
+import qualified Data.Patch.Class as Patch
+import qualified Data.Validity as Validity
 import qualified Test.QuickCheck as QC
-import Gargantext.Core.Text.Terms.Mono (isSep)
 
 
 genScientificText :: Gen T.Text
@@ -89,6 +96,66 @@ tests = describe "Ngrams" $ do
    it "return results for non-empty input terms" $ property testBuildPatternsNonEmpty
   describe "docNgrams" $ do
    it "always matches if the input text contains any of the terms" $ property testDocNgramsOKMatch
+  describe "hierarchical grouping" $ do
+   it "attaching a child with children to a parent should preserve ancestorship" testHierarchicalGrouping
+
+
+hierarchicalCorpus :: NgramsTableMap
+hierarchicalCorpus = Map.fromList [
+    ( "car", NgramsRepoElement { _nre_size     = 1
+             , _nre_list     = MapTerm
+             , _nre_root     = Nothing
+             , _nre_parent   = Nothing
+             , _nre_children = mSetFromList [ "Ford" ]
+             })
+   , ( "Ford", NgramsRepoElement { _nre_size   = 1
+             , _nre_list     = MapTerm
+             , _nre_root     = Just "car"
+             , _nre_parent   = Just "car"
+             , _nre_children = mempty
+             })
+   ]
+
+patchedHierarchicalCorpus :: NgramsTableMap
+patchedHierarchicalCorpus = Map.fromList [
+    ( "vehicle", NgramsRepoElement { _nre_size     = 1
+                 , _nre_list     = MapTerm
+                 , _nre_root     = Nothing
+                 , _nre_parent   = Nothing
+                 , _nre_children = mSetFromList [ "car" ]
+                 })
+    , ( "car", NgramsRepoElement { _nre_size     = 1
+               , _nre_list     = MapTerm
+               , _nre_root     = Just "vehicle"
+               , _nre_parent   = Just "vehicle"
+               , _nre_children = mSetFromList [ "Ford" ]
+               })
+   , ( "Ford", NgramsRepoElement { _nre_size   = 1
+             , _nre_list     = MapTerm
+             , _nre_root     = Just "vehicle"
+             , _nre_parent   = Just "car"
+             , _nre_children = mempty
+             })
+   ]
+
+patchHierarchical :: NgramsTablePatch
+patchHierarchical = mkNgramsTablePatch $ Map.fromList [
+                                 (NgramsTerm "vehicle", NgramsPatch
+                                    { _patch_children = PatchMSet
+                                                      $ fst
+                                                      $ PM.fromList
+                                                      $ [ ( "car", addPatch ) ]
+                                    , _patch_list     = Keep
+                                    }
+                                 )
+                              ]
+
+testHierarchicalGrouping :: Assertion
+testHierarchicalGrouping = do
+  -- Check the patch is applicable
+  Validity.validationIsValid (Patch.applicable patchHierarchical (Just hierarchicalCorpus)) @?= True
+  Patch.act patchHierarchical (Just hierarchicalCorpus) @?= Just patchedHierarchicalCorpus
+
 
 testDocNgramsOKMatch :: Lang -> DocumentWithMatches -> Property
 testDocNgramsOKMatch lang (DocumentWithMatches ts doc) =