1 files changed, 36 insertions, 9 deletions
diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs
index 41725af..8221e91 100644
--- a/src/Erebos/Storage/Merge.hs
+++ b/src/Erebos/Storage/Merge.hs
@@ -7,7 +7,7 @@ module Erebos.Storage.Merge (
     compareGeneration, generationMax,
     storedGeneration,
 
-    generations,
+    generations, generationsBy,
     ancestors,
     precedes,
     precedesOrEquals,
@@ -17,6 +17,8 @@ module Erebos.Storage.Merge (
 
     findProperty,
     findPropertyFirst,
+
+    storedDifference,
 ) where
 
 import Control.Concurrent.MVar
@@ -25,6 +27,8 @@ import Data.ByteString.Char8 qualified as BC
 import Data.HashTable.IO qualified as HT
 import Data.Kind
 import Data.List
+import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty qualified as NE
 import Data.Maybe
 import Data.Set (Set)
 import Data.Set qualified as S
@@ -52,7 +56,7 @@ merge xs = mergeSorted $ filterAncestors xs
 
 storeMerge :: (Mergeable a, Storable a) => [Stored (Component a)] -> IO (Stored a)
 storeMerge [] = error "merge: empty list"
-storeMerge xs@(Stored ref _ : _) = wrappedStore (refStorage ref) $ mergeSorted $ filterAncestors xs
+storeMerge xs@(x : _) = wrappedStore (storedStorage x) $ mergeSorted $ filterAncestors xs
 
 previous :: Storable a => Stored a -> [Stored a]
 previous (Stored ref _) = case load ref of
@@ -100,16 +104,24 @@ storedGeneration x =
 
 -- |Returns list of sets starting with the set of given objects and
 -- intcrementally adding parents.
-generations :: Storable a => [Stored a] -> [Set (Stored a)]
-generations = unfoldr gen . (,S.empty)
-    where gen (hs, cur) = case filter (`S.notMember` cur) hs of
-              []    -> Nothing
-              added -> let next = foldr S.insert cur added
-                        in Just (next, (previous =<< added, next))
+generations :: Storable a => [ Stored a ] -> NonEmpty (Set (Stored a))
+generations = generationsBy previous
+
+-- |Returns list of sets starting with the set of given objects and
+-- intcrementally adding parents, with the first parameter being
+-- a function to get all the parents of given object.
+generationsBy :: Ord a => (a -> [ a ]) -> [ a ] -> NonEmpty (Set a)
+generationsBy parents xs = NE.unfoldr gen ( xs, S.fromList xs )
+  where
+    gen ( hs, cur ) = ( cur, ) $
+        case filter (`S.notMember` cur) (parents =<< hs) of
+            []    -> Nothing
+            added -> let next = foldr S.insert cur added
+                      in Just ( added, next )
 
 -- |Returns set containing all given objects and their ancestors
 ancestors :: Storable a => [Stored a] -> Set (Stored a)
-ancestors = last . (S.empty:) . generations
+ancestors = NE.last . generations
 
 precedes :: Storable a => Stored a -> Stored a -> Bool
 precedes x y = not $ x `elem` filterAncestors [x, y]
@@ -162,3 +174,18 @@ findPropertyFirst sel = fmap (fromJust . sel . fromStored) . listToMaybe . filte
 findPropHeads :: forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a]
 findPropHeads sel sobj | Just _ <- sel $ fromStored sobj = [sobj]
                        | otherwise = findPropHeads sel =<< previous sobj
+
+
+-- | Compute symmetrict difference between two stored histories. In other
+-- words, return all 'Stored a' objects reachable (via 'previous') from first
+-- given set, but not from the second; and vice versa.
+storedDifference :: Storable a => [ Stored a ] -> [ Stored a ] -> [ Stored a ]
+storedDifference xs' ys' =
+    let xs = filterAncestors xs'
+        ys = filterAncestors ys'
+
+        filteredPrevious blocked zs = filterAncestors (previous zs ++ blocked) `diffSorted` blocked
+        xg = S.toAscList $ NE.last $ generationsBy (filteredPrevious ys) $ filterAncestors (xs ++ ys) `diffSorted` ys
+        yg = S.toAscList $ NE.last $ generationsBy (filteredPrevious xs) $ filterAncestors (ys ++ xs) `diffSorted` xs
+
+     in xg `mergeUniq` yg