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
119
Issues
119
List
Board
Labels
Milestones
Merge Requests
7
Merge Requests
7
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
dc48137c
Commit
dc48137c
authored
Jun 05, 2023
by
Alfredo Di Napoli
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Apply ListType replacement on children as well (fixes
#217
)
parent
94000749
Pipeline
#4150
passed with stages
in 65 minutes and 28 seconds
Changes
1
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
33 additions
and
4 deletions
+33
-4
Types.hs
src/Gargantext/API/Ngrams/Types.hs
+33
-4
No files found.
src/Gargantext/API/Ngrams/Types.hs
View file @
dc48137c
...
...
@@ -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,6 +552,10 @@ 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
)
...
...
@@ -648,12 +652,37 @@ reParentAddRem :: RootParent -> NgramsTerm -> AddRem -> State NgramsTableMap ()
reParentAddRem
rp
child
p
=
reParent
(
if
isRem
p
then
Nothing
else
Just
rp
)
child
reParentNgramsPatch
::
NgramsTerm
->
NgramsPatch
->
State
NgramsTableMap
()
-- | 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
...
...
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