Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
191
Issues
191
List
Board
Labels
Milestones
Merge Requests
8
Merge Requests
8
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
51a2fe5a
Commit
51a2fe5a
authored
Jul 07, 2025
by
Alfredo Di Napoli
Committed by
Alfredo Di Napoli
Jul 14, 2025
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Try to reproduce the hierarchical patching bug
parent
64e2a689
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
98 additions
and
19 deletions
+98
-19
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+27
-15
Ngrams.hs
test/Test/Offline/Ngrams.hs
+71
-4
No files found.
src/Gargantext/API/Ngrams.hs
View file @
51a2fe5a
...
...
@@ -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
View file @
51a2fe5a
...
...
@@ -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
)
=
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment