1 files changed, 248 insertions, 0 deletions
diff --git a/src/Erebos/Storage/Graph.hs b/src/Erebos/Storage/Graph.hs
new file mode 100644
index 0000000..79e25bc
--- /dev/null
+++ b/src/Erebos/Storage/Graph.hs
@@ -0,0 +1,248 @@
+module Erebos.Storage.Graph (
+    Generation,
+    showGeneration,
+    compareGeneration, generationMax,
+    storedGeneration,
+
+    generations, generationsBy,
+    ancestors,
+    precedes,
+    precedesOrEquals,
+    filterAncestors,
+    commonAncestors,
+    storedRoots,
+    walkAncestors,
+
+    findProperty,
+    findPropertyFirst,
+
+    storedDifference,
+
+    Graph,
+    graphFromTips, graphRemoveTips,
+    graphSize,
+    graphToList,
+) where
+
+import Control.Arrow
+import Control.Concurrent.MVar
+
+import Data.ByteString.Char8 qualified as BC
+import Data.HashTable.IO qualified as HT
+import Data.List
+import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty qualified as NE
+import Data.Maybe
+import Data.Ord
+import Data.Set (Set)
+import Data.Set qualified as S
+
+import System.IO.Unsafe (unsafePerformIO)
+
+import Erebos.Object
+import Erebos.Storable
+import Erebos.Storage.Internal
+import Erebos.Util
+
+
+previous :: Storable a => Stored a -> [Stored a]
+previous (Stored ref _) = case load ref of
+    Rec items | Just (RecRef dref) <- lookup (BC.pack "SDATA") items
+              , Rec ditems <- load dref ->
+                    map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $
+                        map snd $ filter ((`elem` [ BC.pack "SPREV", BC.pack "SBASE" ]) . fst) ditems
+
+              | otherwise ->
+                    map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $
+                        map snd $ filter ((`elem` [ BC.pack "PREV", BC.pack "BASE" ]) . fst) items
+    _ -> []
+
+
+nextGeneration :: [Generation] -> Generation
+nextGeneration = foldl' helper (Generation 0)
+    where helper (Generation c) (Generation n) | c <= n    = Generation (n + 1)
+                                               | otherwise = Generation c
+
+showGeneration :: Generation -> String
+showGeneration (Generation x) = show x
+
+compareGeneration :: Generation -> Generation -> Maybe Ordering
+compareGeneration (Generation x) (Generation y) = Just $ compare x y
+
+generationMax :: Storable a => [Stored a] -> Maybe (Stored a)
+generationMax (x : xs) = Just $ snd $ foldl' helper (storedGeneration x, x) xs
+    where helper (mg, mx) y = let yg = storedGeneration y
+                               in case compareGeneration mg yg of
+                                       Just LT -> (yg, y)
+                                       _       -> (mg, mx)
+generationMax [] = Nothing
+
+storedGeneration :: Storable a => Stored a -> Generation
+storedGeneration x =
+    unsafePerformIO $ withMVar (stRefGeneration $ refStorage $ storedRef x) $ \ht -> do
+        let doLookup y = HT.lookup ht (refDigest $ storedRef y) >>= \case
+                Just gen -> return gen
+                Nothing -> do
+                    gen <- nextGeneration <$> mapM doLookup (previous y)
+                    HT.insert ht (refDigest $ storedRef y) gen
+                    return gen
+        doLookup x
+
+
+-- |Returns list of sets starting with the set of given objects and
+-- intcrementally adding parents.
+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 )
+
+
+type StoredTips a = [ Stored a ]
+
+-- |Returns set containing all given objects and their ancestors
+ancestors :: Storable a => [Stored a] -> Set (Stored a)
+ancestors = NE.last . generations
+
+precedes :: Storable a => Stored a -> Stored a -> Bool
+precedes x y = not $ x `elem` filterAncestors [x, y]
+
+precedesOrEquals :: Storable a => Stored a -> Stored a -> Bool
+precedesOrEquals x y = filterAncestors [ x, y ] == [ y ]
+
+filterAncestors :: Storable a => [ Stored a ] -> StoredTips a
+filterAncestors [ x ] = [ x ]
+filterAncestors xs = let xs' = uniq $ sort xs
+                      in helper xs' xs'
+    where helper remains walk = case generationMax walk of
+                                     Just x -> let px = previous x
+                                                   remains' = filter (\r -> all (/=r) px) remains
+                                                in helper remains' $ uniq $ sort (px ++ filter (/=x) walk)
+                                     Nothing -> remains
+
+commonAncestors :: Storable a => [ Stored a ] -> [ Stored a ] -> StoredTips a
+commonAncestors [] _ = []
+commonAncestors _ [] = []
+commonAncestors oxs oys = sort $ gom oxs' oys'
+  where
+    maximumGen = maximumBy (comparing (\(Generation n) ->  n))
+    oxs' = map (storedGeneration &&& id) oxs
+    oys' = map (storedGeneration &&& id) oys
+
+    gom [] _ = []
+    gom _ [] = []
+    gom xs ys = go (maximumGen (map fst xs ++ map fst ys)) xs ys
+
+    go g xs ys =
+        let ( cxs, nxs ) = partition ((g ==) . fst) xs
+            ( cys, nys ) = partition ((g ==) . fst) ys
+            ( common, ( cxs', cys' ) ) = takeCommon (uniq $ sort $ map snd cxs) (uniq $ sort $ map snd cys)
+            pxs = map (storedGeneration &&& id) $ concatMap previous cxs'
+            pys = map (storedGeneration &&& id) $ concatMap previous cys'
+         in case ( pxs, pys ) of
+                ( [], [] ) -> common ++ gom nxs nys
+                ( _ , _  ) -> common ++ go (maximumGen (map fst pxs ++ map fst pys)) (pxs ++ nxs) (pys ++ nys)
+
+    takeCommon (x : xs) (y : ys)
+        | x < y = second (first  (x :)) $ takeCommon xs (y : ys)
+        | y < x = second (second (y :)) $ takeCommon (x : xs) ys
+        | otherwise = first (x :) $ takeCommon xs ys
+    takeCommon [] ys = ( [], ( [], ys ))
+    takeCommon xs [] = ( [], ( xs, [] ))
+
+
+storedRoots :: Storable a => Stored a -> [Stored a]
+storedRoots x = do
+    let st = refStorage $ storedRef x
+    unsafePerformIO $ withMVar (stRefRoots st) $ \ht -> do
+        let doLookup y = HT.lookup ht (refDigest $ storedRef y) >>= \case
+                Just roots -> return roots
+                Nothing -> do
+                    roots <- case previous y of
+                        [] -> return [refDigest $ storedRef y]
+                        ps -> map (refDigest . storedRef) . filterAncestors . map (wrappedLoad @Object . Ref st) . concat <$> mapM doLookup ps
+                    HT.insert ht (refDigest $ storedRef y) roots
+                    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 sel =<<)
+
+findPropertyFirst :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> Maybe b
+findPropertyFirst sel = fmap (fromJust . sel . fromStored) . listToMaybe . filterAncestors . (findPropHeads sel =<<)
+
+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
+
+
+data Graph a = Graph
+    { graphHead :: StoredTips a
+    , graphTail :: StoredTips a
+    }
+
+graphFromTips :: StoredTips a -> Graph a
+graphFromTips h = Graph h []
+
+graphRemoveTips :: Storable a => StoredTips a -> Graph a -> Graph a
+graphRemoveTips remove g =
+    let gheads = filter (\h -> not $ any (h `precedesOrEquals`) remove) (graphHead g)
+        gtails = commonAncestors gheads $ graphTail g ++ remove
+     in Graph { graphHead = gheads, graphTail = gtails }
+
+graphSize :: Storable a => Graph a -> Int
+graphSize = length . graphToList (\_ _ -> EQ)
+
+graphToList :: Storable a => (Stored a -> Stored a -> Ordering) -> Graph a -> [ Stored a ]
+graphToList cmp Graph {..} = go S.empty graphHead
+  where
+    go _ [] = []
+    go used (x : xs)
+        | ( x', xs' ) <- selectMax x xs
+        = x' : go (S.insert x used) (xs' ++ filter (\(p :: Stored a) -> not $ p `S.member` used || any (p `precedesOrEquals`) graphTail) (previous x))
+
+    cmp' x y = case cmp x y of EQ -> compare x y
+                               o  -> o
+
+    selectMax y (x : xs)
+        = case cmp' y x of
+              LT -> (y :) <$> selectMax x xs
+              EQ -> selectMax y xs
+              GT -> (x :) <$> selectMax y xs
+    selectMax y [] = ( y, [] )