summaryrefslogtreecommitdiff
path: root/src/Storage/Merge.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-07-17 15:36:23 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-07-17 21:19:23 +0200
commit36eb3a419ec9d0434f55456090e2845d4ac20b58 (patch)
treef32d3ff500863a3528c1b4008b736c1cc77fb084 /src/Storage/Merge.hs
parent1986e8f51b992edcc675e76edd5d1f85522b8e6d (diff)
Set of mergeable items
Diffstat (limited to 'src/Storage/Merge.hs')
-rw-r--r--src/Storage/Merge.hs18
1 files changed, 18 insertions, 0 deletions
diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs
index cedf56a..82737ef 100644
--- a/src/Storage/Merge.hs
+++ b/src/Storage/Merge.hs
@@ -11,6 +11,7 @@ module Storage.Merge (
precedes,
filterAncestors,
storedRoots,
+ walkAncestors,
findProperty,
) where
@@ -36,6 +37,11 @@ class Storable (Component a) => Mergeable a where
mergeSorted :: [Stored (Component a)] -> a
toComponents :: a -> [Stored (Component a)]
+instance Mergeable [Stored Object] where
+ type Component [Stored Object] = Object
+ mergeSorted = id
+ toComponents = id
+
merge :: Mergeable a => [Stored (Component a)] -> a
merge [] = error "merge: empty list"
merge xs = mergeSorted $ filterAncestors xs
@@ -122,6 +128,18 @@ storedRoots x = do
return roots
map (wrappedLoad . Ref st) <$> doLookup x
+walkAncestors :: (Storable a, Monoid m) => (Stored a -> m) -> [Stored a] -> m
+walkAncestors f = helper . sortBy cmp
+ where
+ helper (x : y : xs) | x == y = helper (x : xs)
+ helper (x : xs) = f x <> helper (mergeBy cmp (sortBy cmp (previous x)) xs)
+ helper [] = mempty
+
+ cmp x y = case compareGeneration (storedGeneration x) (storedGeneration y) of
+ Just LT -> GT
+ Just GT -> LT
+ _ -> compare x y
+
findProperty :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> [b]
findProperty sel = map (fromJust . sel . fromStored) . filterAncestors . (findPropHeads =<<)
where findPropHeads :: Stored a -> [Stored a]