From 36eb3a419ec9d0434f55456090e2845d4ac20b58 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 17 Jul 2022 15:36:23 +0200
Subject: Set of mergeable items

---
 src/Storage/Merge.hs | 18 ++++++++++++++++++
 1 file changed, 18 insertions(+)

(limited to 'src/Storage')

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]
-- 
cgit v1.2.3