module Erebos.Storage.Merge (
    Mergeable(..),
    merge, storeMerge,

    Generation,
    showGeneration,
    compareGeneration, generationMax,
    storedGeneration,

    generations,
    ancestors,
    precedes,
    precedesOrEquals,
    filterAncestors,
    storedRoots,
    walkAncestors,

    findProperty,
    findPropertyFirst,
) where

import Control.Concurrent.MVar

import Data.ByteString.Char8 qualified as BC
import Data.HashTable.IO qualified as HT
import Data.Kind
import Data.List
import Data.Maybe
import Data.Set (Set)
import Data.Set qualified as S

import System.IO.Unsafe (unsafePerformIO)

import Erebos.Storage
import Erebos.Storage.Internal
import Erebos.Util

class Storable (Component a) => Mergeable a where
    type Component a :: Type
    mergeSorted :: [Stored (Component a)] -> a
    toComponents :: a -> [Stored (Component a)]

instance Mergeable [Stored Object] where
    type Component [Stored Object] = Object
    mergeSorted :: [Stored (Component [Stored Object])] -> [Stored Object]
mergeSorted = [Stored Object] -> [Stored Object]
[Stored (Component [Stored Object])] -> [Stored Object]
forall a. a -> a
id
    toComponents :: [Stored Object] -> [Stored (Component [Stored Object])]
toComponents = [Stored Object] -> [Stored Object]
[Stored Object] -> [Stored (Component [Stored Object])]
forall a. a -> a
id

merge :: Mergeable a => [Stored (Component a)] -> a
merge :: forall a. Mergeable a => [Stored (Component a)] -> a
merge [] = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"merge: empty list"
merge [Stored (Component a)]
xs = [Stored (Component a)] -> a
forall a. Mergeable a => [Stored (Component a)] -> a
mergeSorted ([Stored (Component a)] -> a) -> [Stored (Component a)] -> a
forall a b. (a -> b) -> a -> b
$ [Stored (Component a)] -> [Stored (Component a)]
forall a. Storable a => [Stored a] -> [Stored a]
filterAncestors [Stored (Component a)]
xs

storeMerge :: (Mergeable a, Storable a) => [Stored (Component a)] -> IO (Stored a)
storeMerge :: forall a.
(Mergeable a, Storable a) =>
[Stored (Component a)] -> IO (Stored a)
storeMerge [] = [Char] -> IO (Stored a)
forall a. HasCallStack => [Char] -> a
error [Char]
"merge: empty list"
storeMerge xs :: [Stored (Component a)]
xs@(Stored Ref' Complete
ref Component a
_ : [Stored (Component a)]
_) = Storage -> a -> IO (Stored a)
forall (m :: * -> *) a.
(MonadIO m, Storable a) =>
Storage -> a -> m (Stored a)
wrappedStore (Ref' Complete -> Storage
forall (c :: * -> *). Ref' c -> Storage' c
refStorage Ref' Complete
ref) (a -> IO (Stored a)) -> a -> IO (Stored a)
forall a b. (a -> b) -> a -> b
$ [Stored (Component a)] -> a
forall a. Mergeable a => [Stored (Component a)] -> a
mergeSorted ([Stored (Component a)] -> a) -> [Stored (Component a)] -> a
forall a b. (a -> b) -> a -> b
$ [Stored (Component a)] -> [Stored (Component a)]
forall a. Storable a => [Stored a] -> [Stored a]
filterAncestors [Stored (Component a)]
xs

previous :: Storable a => Stored a -> [Stored a]
previous :: forall a. Storable a => Stored a -> [Stored a]
previous (Stored Ref' Complete
ref a
_) = case Ref' Complete -> Object
forall a. Storable a => Ref' Complete -> a
load Ref' Complete
ref of
    Rec [(ByteString, RecItem' Complete)]
items | Just (RecRef Ref' Complete
dref) <- ByteString
-> [(ByteString, RecItem' Complete)] -> Maybe (RecItem' Complete)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ([Char] -> ByteString
BC.pack [Char]
"SDATA") [(ByteString, RecItem' Complete)]
items
              , Rec [(ByteString, RecItem' Complete)]
ditems <- Ref' Complete -> Object
forall a. Storable a => Ref' Complete -> a
load Ref' Complete
dref ->
                    (Ref' Complete -> Stored' Complete a)
-> [Ref' Complete] -> [Stored' Complete a]
forall a b. (a -> b) -> [a] -> [b]
map Ref' Complete -> Stored' Complete a
forall a. Storable a => Ref' Complete -> Stored a
wrappedLoad ([Ref' Complete] -> [Stored' Complete a])
-> [Ref' Complete] -> [Stored' Complete a]
forall a b. (a -> b) -> a -> b
$ [Maybe (Ref' Complete)] -> [Ref' Complete]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Ref' Complete)] -> [Ref' Complete])
-> [Maybe (Ref' Complete)] -> [Ref' Complete]
forall a b. (a -> b) -> a -> b
$ (RecItem' Complete -> Maybe (Ref' Complete))
-> [RecItem' Complete] -> [Maybe (Ref' Complete)]
forall a b. (a -> b) -> [a] -> [b]
map (\case RecRef Ref' Complete
r -> Ref' Complete -> Maybe (Ref' Complete)
forall a. a -> Maybe a
Just Ref' Complete
r; RecItem' Complete
_ -> Maybe (Ref' Complete)
forall a. Maybe a
Nothing) ([RecItem' Complete] -> [Maybe (Ref' Complete)])
-> [RecItem' Complete] -> [Maybe (Ref' Complete)]
forall a b. (a -> b) -> a -> b
$
                        ((ByteString, RecItem' Complete) -> RecItem' Complete)
-> [(ByteString, RecItem' Complete)] -> [RecItem' Complete]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, RecItem' Complete) -> RecItem' Complete
forall a b. (a, b) -> b
snd ([(ByteString, RecItem' Complete)] -> [RecItem' Complete])
-> [(ByteString, RecItem' Complete)] -> [RecItem' Complete]
forall a b. (a -> b) -> a -> b
$ ((ByteString, RecItem' Complete) -> Bool)
-> [(ByteString, RecItem' Complete)]
-> [(ByteString, RecItem' Complete)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ [Char] -> ByteString
BC.pack [Char]
"SPREV", [Char] -> ByteString
BC.pack [Char]
"SBASE" ]) (ByteString -> Bool)
-> ((ByteString, RecItem' Complete) -> ByteString)
-> (ByteString, RecItem' Complete)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, RecItem' Complete) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, RecItem' Complete)]
ditems

              | Bool
otherwise ->
                    (Ref' Complete -> Stored' Complete a)
-> [Ref' Complete] -> [Stored' Complete a]
forall a b. (a -> b) -> [a] -> [b]
map Ref' Complete -> Stored' Complete a
forall a. Storable a => Ref' Complete -> Stored a
wrappedLoad ([Ref' Complete] -> [Stored' Complete a])
-> [Ref' Complete] -> [Stored' Complete a]
forall a b. (a -> b) -> a -> b
$ [Maybe (Ref' Complete)] -> [Ref' Complete]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Ref' Complete)] -> [Ref' Complete])
-> [Maybe (Ref' Complete)] -> [Ref' Complete]
forall a b. (a -> b) -> a -> b
$ (RecItem' Complete -> Maybe (Ref' Complete))
-> [RecItem' Complete] -> [Maybe (Ref' Complete)]
forall a b. (a -> b) -> [a] -> [b]
map (\case RecRef Ref' Complete
r -> Ref' Complete -> Maybe (Ref' Complete)
forall a. a -> Maybe a
Just Ref' Complete
r; RecItem' Complete
_ -> Maybe (Ref' Complete)
forall a. Maybe a
Nothing) ([RecItem' Complete] -> [Maybe (Ref' Complete)])
-> [RecItem' Complete] -> [Maybe (Ref' Complete)]
forall a b. (a -> b) -> a -> b
$
                        ((ByteString, RecItem' Complete) -> RecItem' Complete)
-> [(ByteString, RecItem' Complete)] -> [RecItem' Complete]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, RecItem' Complete) -> RecItem' Complete
forall a b. (a, b) -> b
snd ([(ByteString, RecItem' Complete)] -> [RecItem' Complete])
-> [(ByteString, RecItem' Complete)] -> [RecItem' Complete]
forall a b. (a -> b) -> a -> b
$ ((ByteString, RecItem' Complete) -> Bool)
-> [(ByteString, RecItem' Complete)]
-> [(ByteString, RecItem' Complete)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ [Char] -> ByteString
BC.pack [Char]
"PREV", [Char] -> ByteString
BC.pack [Char]
"BASE" ]) (ByteString -> Bool)
-> ((ByteString, RecItem' Complete) -> ByteString)
-> (ByteString, RecItem' Complete)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, RecItem' Complete) -> ByteString
forall a b. (a, b) -> a
fst) [(ByteString, RecItem' Complete)]
items
    Object
_ -> []


nextGeneration :: [Generation] -> Generation
nextGeneration :: [Generation] -> Generation
nextGeneration = (Generation -> Generation -> Generation)
-> Generation -> [Generation] -> Generation
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Generation -> Generation -> Generation
helper (Int -> Generation
Generation Int
0)
    where helper :: Generation -> Generation -> Generation
helper (Generation Int
c) (Generation Int
n) | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n    = Int -> Generation
Generation (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                                               | Bool
otherwise = Int -> Generation
Generation Int
c

showGeneration :: Generation -> String
showGeneration :: Generation -> [Char]
showGeneration (Generation Int
x) = Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x

compareGeneration :: Generation -> Generation -> Maybe Ordering
compareGeneration :: Generation -> Generation -> Maybe Ordering
compareGeneration (Generation Int
x) (Generation Int
y) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
x Int
y

generationMax :: Storable a => [Stored a] -> Maybe (Stored a)
generationMax :: forall a. Storable a => [Stored a] -> Maybe (Stored a)
generationMax (Stored a
x : [Stored a]
xs) = Stored a -> Maybe (Stored a)
forall a. a -> Maybe a
Just (Stored a -> Maybe (Stored a)) -> Stored a -> Maybe (Stored a)
forall a b. (a -> b) -> a -> b
$ (Generation, Stored a) -> Stored a
forall a b. (a, b) -> b
snd ((Generation, Stored a) -> Stored a)
-> (Generation, Stored a) -> Stored a
forall a b. (a -> b) -> a -> b
$ ((Generation, Stored a) -> Stored a -> (Generation, Stored a))
-> (Generation, Stored a) -> [Stored a] -> (Generation, Stored a)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Generation, Stored a) -> Stored a -> (Generation, Stored a)
forall {a}.
Storable a =>
(Generation, Stored a) -> Stored a -> (Generation, Stored a)
helper (Stored a -> Generation
forall a. Storable a => Stored a -> Generation
storedGeneration Stored a
x, Stored a
x) [Stored a]
xs
    where helper :: (Generation, Stored a) -> Stored a -> (Generation, Stored a)
helper (Generation
mg, Stored a
mx) Stored a
y = let yg :: Generation
yg = Stored a -> Generation
forall a. Storable a => Stored a -> Generation
storedGeneration Stored a
y
                               in case Generation -> Generation -> Maybe Ordering
compareGeneration Generation
mg Generation
yg of
                                       Just Ordering
LT -> (Generation
yg, Stored a
y)
                                       Maybe Ordering
_       -> (Generation
mg, Stored a
mx)
generationMax [] = Maybe (Stored a)
forall a. Maybe a
Nothing

storedGeneration :: Storable a => Stored a -> Generation
storedGeneration :: forall a. Storable a => Stored a -> Generation
storedGeneration Stored a
x =
    IO Generation -> Generation
forall a. IO a -> a
unsafePerformIO (IO Generation -> Generation) -> IO Generation -> Generation
forall a b. (a -> b) -> a -> b
$ MVar (HashTable RealWorld RefDigest Generation)
-> (HashTable RealWorld RefDigest Generation -> IO Generation)
-> IO Generation
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Storage -> MVar (BasicHashTable RefDigest Generation)
forall (c :: * -> *).
Storage' c -> MVar (BasicHashTable RefDigest Generation)
stRefGeneration (Storage -> MVar (BasicHashTable RefDigest Generation))
-> Storage -> MVar (BasicHashTable RefDigest Generation)
forall a b. (a -> b) -> a -> b
$ Ref' Complete -> Storage
forall (c :: * -> *). Ref' c -> Storage' c
refStorage (Ref' Complete -> Storage) -> Ref' Complete -> Storage
forall a b. (a -> b) -> a -> b
$ Stored a -> Ref' Complete
forall a. Stored a -> Ref' Complete
storedRef Stored a
x) ((HashTable RealWorld RefDigest Generation -> IO Generation)
 -> IO Generation)
-> (HashTable RealWorld RefDigest Generation -> IO Generation)
-> IO Generation
forall a b. (a -> b) -> a -> b
$ \HashTable RealWorld RefDigest Generation
ht -> do
        let doLookup :: Stored a -> IO Generation
doLookup Stored a
y = BasicHashTable RefDigest Generation
-> RefDigest -> IO (Maybe Generation)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
HT.lookup HashTable RealWorld RefDigest Generation
BasicHashTable RefDigest Generation
ht (Ref' Complete -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref' Complete -> RefDigest) -> Ref' Complete -> RefDigest
forall a b. (a -> b) -> a -> b
$ Stored a -> Ref' Complete
forall a. Stored a -> Ref' Complete
storedRef Stored a
y) IO (Maybe Generation)
-> (Maybe Generation -> IO Generation) -> IO Generation
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just Generation
gen -> Generation -> IO Generation
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Generation
gen
                Maybe Generation
Nothing -> do
                    Generation
gen <- [Generation] -> Generation
nextGeneration ([Generation] -> Generation) -> IO [Generation] -> IO Generation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Stored a -> IO Generation) -> [Stored a] -> IO [Generation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Stored a -> IO Generation
doLookup (Stored a -> [Stored a]
forall a. Storable a => Stored a -> [Stored a]
previous Stored a
y)
                    BasicHashTable RefDigest Generation
-> RefDigest -> Generation -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
HT.insert HashTable RealWorld RefDigest Generation
BasicHashTable RefDigest Generation
ht (Ref' Complete -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref' Complete -> RefDigest) -> Ref' Complete -> RefDigest
forall a b. (a -> b) -> a -> b
$ Stored a -> Ref' Complete
forall a. Stored a -> Ref' Complete
storedRef Stored a
y) Generation
gen
                    Generation -> IO Generation
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Generation
gen
        Stored a -> IO Generation
doLookup Stored a
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 :: forall a. Storable a => [Stored a] -> [Set (Stored a)]
generations = (([Stored a], Set (Stored a))
 -> Maybe (Set (Stored a), ([Stored a], Set (Stored a))))
-> ([Stored a], Set (Stored a)) -> [Set (Stored a)]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr ([Stored a], Set (Stored a))
-> Maybe (Set (Stored a), ([Stored a], Set (Stored a)))
forall {a}.
Storable a =>
([Stored a], Set (Stored a))
-> Maybe (Set (Stored a), ([Stored a], Set (Stored a)))
gen (([Stored a], Set (Stored a)) -> [Set (Stored a)])
-> ([Stored a] -> ([Stored a], Set (Stored a)))
-> [Stored a]
-> [Set (Stored a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Set (Stored a)
forall a. Set a
S.empty)
    where gen :: ([Stored a], Set (Stored a))
-> Maybe (Set (Stored a), ([Stored a], Set (Stored a)))
gen ([Stored a]
hs, Set (Stored a)
cur) = case (Stored a -> Bool) -> [Stored a] -> [Stored a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Stored a -> Set (Stored a) -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set (Stored a)
cur) [Stored a]
hs of
              []    -> Maybe (Set (Stored a), ([Stored a], Set (Stored a)))
forall a. Maybe a
Nothing
              [Stored a]
added -> let next :: Set (Stored a)
next = (Stored a -> Set (Stored a) -> Set (Stored a))
-> Set (Stored a) -> [Stored a] -> Set (Stored a)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Stored a -> Set (Stored a) -> Set (Stored a)
forall a. Ord a => a -> Set a -> Set a
S.insert Set (Stored a)
cur [Stored a]
added
                        in (Set (Stored a), ([Stored a], Set (Stored a)))
-> Maybe (Set (Stored a), ([Stored a], Set (Stored a)))
forall a. a -> Maybe a
Just (Set (Stored a)
next, (Stored a -> [Stored a]
forall a. Storable a => Stored a -> [Stored a]
previous (Stored a -> [Stored a]) -> [Stored a] -> [Stored a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Stored a]
added, Set (Stored a)
next))

-- |Returns set containing all given objects and their ancestors
ancestors :: Storable a => [Stored a] -> Set (Stored a)
ancestors :: forall a. Storable a => [Stored a] -> Set (Stored a)
ancestors = [Set (Stored a)] -> Set (Stored a)
forall a. HasCallStack => [a] -> a
last ([Set (Stored a)] -> Set (Stored a))
-> ([Stored a] -> [Set (Stored a)]) -> [Stored a] -> Set (Stored a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (Stored a)
forall a. Set a
S.emptySet (Stored a) -> [Set (Stored a)] -> [Set (Stored a)]
forall a. a -> [a] -> [a]
:) ([Set (Stored a)] -> [Set (Stored a)])
-> ([Stored a] -> [Set (Stored a)])
-> [Stored a]
-> [Set (Stored a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stored a] -> [Set (Stored a)]
forall a. Storable a => [Stored a] -> [Set (Stored a)]
generations

precedes :: Storable a => Stored a -> Stored a -> Bool
precedes :: forall a. Storable a => Stored a -> Stored a -> Bool
precedes Stored a
x Stored a
y = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Stored a
x Stored a -> [Stored a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Stored a] -> [Stored a]
forall a. Storable a => [Stored a] -> [Stored a]
filterAncestors [Stored a
x, Stored a
y]

precedesOrEquals :: Storable a => Stored a -> Stored a -> Bool
precedesOrEquals :: forall a. Storable a => Stored a -> Stored a -> Bool
precedesOrEquals Stored a
x Stored a
y = [Stored a] -> [Stored a]
forall a. Storable a => [Stored a] -> [Stored a]
filterAncestors [ Stored a
x, Stored a
y ] [Stored a] -> [Stored a] -> Bool
forall a. Eq a => a -> a -> Bool
== [ Stored a
y ]

filterAncestors :: Storable a => [Stored a] -> [Stored a]
filterAncestors :: forall a. Storable a => [Stored a] -> [Stored a]
filterAncestors [Stored a
x] = [Stored a
x]
filterAncestors [Stored a]
xs = let xs' :: [Stored a]
xs' = [Stored a] -> [Stored a]
forall a. Eq a => [a] -> [a]
uniq ([Stored a] -> [Stored a]) -> [Stored a] -> [Stored a]
forall a b. (a -> b) -> a -> b
$ [Stored a] -> [Stored a]
forall a. Ord a => [a] -> [a]
sort [Stored a]
xs
                      in [Stored a] -> [Stored a] -> [Stored a]
forall {a}. Storable a => [Stored a] -> [Stored a] -> [Stored a]
helper [Stored a]
xs' [Stored a]
xs'
    where helper :: [Stored a] -> [Stored a] -> [Stored a]
helper [Stored a]
remains [Stored a]
walk = case [Stored a] -> Maybe (Stored a)
forall a. Storable a => [Stored a] -> Maybe (Stored a)
generationMax [Stored a]
walk of
                                     Just Stored a
x -> let px :: [Stored a]
px = Stored a -> [Stored a]
forall a. Storable a => Stored a -> [Stored a]
previous Stored a
x
                                                   remains' :: [Stored a]
remains' = (Stored a -> Bool) -> [Stored a] -> [Stored a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Stored a
r -> (Stored a -> Bool) -> [Stored a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Stored a -> Stored a -> Bool
forall a. Eq a => a -> a -> Bool
/=Stored a
r) [Stored a]
px) [Stored a]
remains
                                                in [Stored a] -> [Stored a] -> [Stored a]
helper [Stored a]
remains' ([Stored a] -> [Stored a]) -> [Stored a] -> [Stored a]
forall a b. (a -> b) -> a -> b
$ [Stored a] -> [Stored a]
forall a. Eq a => [a] -> [a]
uniq ([Stored a] -> [Stored a]) -> [Stored a] -> [Stored a]
forall a b. (a -> b) -> a -> b
$ [Stored a] -> [Stored a]
forall a. Ord a => [a] -> [a]
sort ([Stored a]
px [Stored a] -> [Stored a] -> [Stored a]
forall a. [a] -> [a] -> [a]
++ (Stored a -> Bool) -> [Stored a] -> [Stored a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Stored a -> Stored a -> Bool
forall a. Eq a => a -> a -> Bool
/=Stored a
x) [Stored a]
walk)
                                     Maybe (Stored a)
Nothing -> [Stored a]
remains

storedRoots :: Storable a => Stored a -> [Stored a]
storedRoots :: forall a. Storable a => Stored a -> [Stored a]
storedRoots Stored a
x = do
    let st :: Storage
st = Ref' Complete -> Storage
forall (c :: * -> *). Ref' c -> Storage' c
refStorage (Ref' Complete -> Storage) -> Ref' Complete -> Storage
forall a b. (a -> b) -> a -> b
$ Stored a -> Ref' Complete
forall a. Stored a -> Ref' Complete
storedRef Stored a
x
    IO [Stored a] -> [Stored a]
forall a. IO a -> a
unsafePerformIO (IO [Stored a] -> [Stored a]) -> IO [Stored a] -> [Stored a]
forall a b. (a -> b) -> a -> b
$ MVar (HashTable RealWorld RefDigest [RefDigest])
-> (HashTable RealWorld RefDigest [RefDigest] -> IO [Stored a])
-> IO [Stored a]
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Storage -> MVar (BasicHashTable RefDigest [RefDigest])
forall (c :: * -> *).
Storage' c -> MVar (BasicHashTable RefDigest [RefDigest])
stRefRoots Storage
st) ((HashTable RealWorld RefDigest [RefDigest] -> IO [Stored a])
 -> IO [Stored a])
-> (HashTable RealWorld RefDigest [RefDigest] -> IO [Stored a])
-> IO [Stored a]
forall a b. (a -> b) -> a -> b
$ \HashTable RealWorld RefDigest [RefDigest]
ht -> do
        let doLookup :: Stored a -> IO [RefDigest]
doLookup Stored a
y = BasicHashTable RefDigest [RefDigest]
-> RefDigest -> IO (Maybe [RefDigest])
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
HT.lookup HashTable RealWorld RefDigest [RefDigest]
BasicHashTable RefDigest [RefDigest]
ht (Ref' Complete -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref' Complete -> RefDigest) -> Ref' Complete -> RefDigest
forall a b. (a -> b) -> a -> b
$ Stored a -> Ref' Complete
forall a. Stored a -> Ref' Complete
storedRef Stored a
y) IO (Maybe [RefDigest])
-> (Maybe [RefDigest] -> IO [RefDigest]) -> IO [RefDigest]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just [RefDigest]
roots -> [RefDigest] -> IO [RefDigest]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [RefDigest]
roots
                Maybe [RefDigest]
Nothing -> do
                    [RefDigest]
roots <- case Stored a -> [Stored a]
forall a. Storable a => Stored a -> [Stored a]
previous Stored a
y of
                        [] -> [RefDigest] -> IO [RefDigest]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Ref' Complete -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref' Complete -> RefDigest) -> Ref' Complete -> RefDigest
forall a b. (a -> b) -> a -> b
$ Stored a -> Ref' Complete
forall a. Stored a -> Ref' Complete
storedRef Stored a
y]
                        [Stored a]
ps -> (Stored Object -> RefDigest) -> [Stored Object] -> [RefDigest]
forall a b. (a -> b) -> [a] -> [b]
map (Ref' Complete -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref' Complete -> RefDigest)
-> (Stored Object -> Ref' Complete) -> Stored Object -> RefDigest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored Object -> Ref' Complete
forall a. Stored a -> Ref' Complete
storedRef) ([Stored Object] -> [RefDigest])
-> ([[RefDigest]] -> [Stored Object])
-> [[RefDigest]]
-> [RefDigest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stored Object] -> [Stored Object]
forall a. Storable a => [Stored a] -> [Stored a]
filterAncestors ([Stored Object] -> [Stored Object])
-> ([[RefDigest]] -> [Stored Object])
-> [[RefDigest]]
-> [Stored Object]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RefDigest -> Stored Object) -> [RefDigest] -> [Stored Object]
forall a b. (a -> b) -> [a] -> [b]
map (forall a. Storable a => Ref' Complete -> Stored a
wrappedLoad @Object (Ref' Complete -> Stored Object)
-> (RefDigest -> Ref' Complete) -> RefDigest -> Stored Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Storage -> RefDigest -> Ref' Complete
forall (c :: * -> *). Storage' c -> RefDigest -> Ref' c
Ref Storage
st) ([RefDigest] -> [Stored Object])
-> ([[RefDigest]] -> [RefDigest])
-> [[RefDigest]]
-> [Stored Object]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[RefDigest]] -> [RefDigest]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[RefDigest]] -> [RefDigest])
-> IO [[RefDigest]] -> IO [RefDigest]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Stored a -> IO [RefDigest]) -> [Stored a] -> IO [[RefDigest]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Stored a -> IO [RefDigest]
doLookup [Stored a]
ps
                    BasicHashTable RefDigest [RefDigest]
-> RefDigest -> [RefDigest] -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
HT.insert HashTable RealWorld RefDigest [RefDigest]
BasicHashTable RefDigest [RefDigest]
ht (Ref' Complete -> RefDigest
forall (c :: * -> *). Ref' c -> RefDigest
refDigest (Ref' Complete -> RefDigest) -> Ref' Complete -> RefDigest
forall a b. (a -> b) -> a -> b
$ Stored a -> Ref' Complete
forall a. Stored a -> Ref' Complete
storedRef Stored a
y) [RefDigest]
roots
                    [RefDigest] -> IO [RefDigest]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [RefDigest]
roots
        (RefDigest -> Stored a) -> [RefDigest] -> [Stored a]
forall a b. (a -> b) -> [a] -> [b]
map (Ref' Complete -> Stored a
forall a. Storable a => Ref' Complete -> Stored a
wrappedLoad (Ref' Complete -> Stored a)
-> (RefDigest -> Ref' Complete) -> RefDigest -> Stored a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Storage -> RefDigest -> Ref' Complete
forall (c :: * -> *). Storage' c -> RefDigest -> Ref' c
Ref Storage
st) ([RefDigest] -> [Stored a]) -> IO [RefDigest] -> IO [Stored a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stored a -> IO [RefDigest]
doLookup Stored a
x

walkAncestors :: (Storable a, Monoid m) => (Stored a -> m) -> [Stored a] -> m
walkAncestors :: forall a m.
(Storable a, Monoid m) =>
(Stored a -> m) -> [Stored a] -> m
walkAncestors Stored' Complete a -> m
f = [Stored' Complete a] -> m
helper ([Stored' Complete a] -> m)
-> ([Stored' Complete a] -> [Stored' Complete a])
-> [Stored' Complete a]
-> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stored' Complete a -> Stored' Complete a -> Ordering)
-> [Stored' Complete a] -> [Stored' Complete a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Stored' Complete a -> Stored' Complete a -> Ordering
forall {a}. Storable a => Stored a -> Stored a -> Ordering
cmp
  where
    helper :: [Stored' Complete a] -> m
helper (Stored' Complete a
x : Stored' Complete a
y : [Stored' Complete a]
xs) | Stored' Complete a
x Stored' Complete a -> Stored' Complete a -> Bool
forall a. Eq a => a -> a -> Bool
== Stored' Complete a
y = [Stored' Complete a] -> m
helper (Stored' Complete a
x Stored' Complete a -> [Stored' Complete a] -> [Stored' Complete a]
forall a. a -> [a] -> [a]
: [Stored' Complete a]
xs)
    helper (Stored' Complete a
x : [Stored' Complete a]
xs) = Stored' Complete a -> m
f Stored' Complete a
x m -> m -> m
forall a. Semigroup a => a -> a -> a
<> [Stored' Complete a] -> m
helper ((Stored' Complete a -> Stored' Complete a -> Ordering)
-> [Stored' Complete a]
-> [Stored' Complete a]
-> [Stored' Complete a]
forall a. (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy Stored' Complete a -> Stored' Complete a -> Ordering
forall {a}. Storable a => Stored a -> Stored a -> Ordering
cmp ((Stored' Complete a -> Stored' Complete a -> Ordering)
-> [Stored' Complete a] -> [Stored' Complete a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Stored' Complete a -> Stored' Complete a -> Ordering
forall {a}. Storable a => Stored a -> Stored a -> Ordering
cmp (Stored' Complete a -> [Stored' Complete a]
forall a. Storable a => Stored a -> [Stored a]
previous Stored' Complete a
x)) [Stored' Complete a]
xs)
    helper [] = m
forall a. Monoid a => a
mempty

    cmp :: Stored a -> Stored a -> Ordering
cmp Stored a
x Stored a
y = case Generation -> Generation -> Maybe Ordering
compareGeneration (Stored a -> Generation
forall a. Storable a => Stored a -> Generation
storedGeneration Stored a
x) (Stored a -> Generation
forall a. Storable a => Stored a -> Generation
storedGeneration Stored a
y) of
                   Just Ordering
LT -> Ordering
GT
                   Just Ordering
GT -> Ordering
LT
                   Maybe Ordering
_ -> Stored a -> Stored a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Stored a
x Stored a
y

findProperty :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> [b]
findProperty :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> [b]
findProperty a -> Maybe b
sel = (Stored a -> b) -> [Stored a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe b -> b
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe b -> b) -> (Stored a -> Maybe b) -> Stored a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
sel (a -> Maybe b) -> (Stored a -> a) -> Stored a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored a -> a
forall a. Stored a -> a
fromStored) ([Stored a] -> [b])
-> ([Stored a] -> [Stored a]) -> [Stored a] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stored a] -> [Stored a]
forall a. Storable a => [Stored a] -> [Stored a]
filterAncestors ([Stored a] -> [Stored a])
-> ([Stored a] -> [Stored a]) -> [Stored a] -> [Stored a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> Maybe b) -> Stored a -> [Stored a]
forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a]
findPropHeads a -> Maybe b
sel (Stored a -> [Stored a]) -> [Stored a] -> [Stored a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)

findPropertyFirst :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> Maybe b
findPropertyFirst :: forall a b. Storable a => (a -> Maybe b) -> [Stored a] -> Maybe b
findPropertyFirst a -> Maybe b
sel = (Stored a -> b) -> Maybe (Stored a) -> Maybe b
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe b -> b
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe b -> b) -> (Stored a -> Maybe b) -> Stored a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
sel (a -> Maybe b) -> (Stored a -> a) -> Stored a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stored a -> a
forall a. Stored a -> a
fromStored) (Maybe (Stored a) -> Maybe b)
-> ([Stored a] -> Maybe (Stored a)) -> [Stored a] -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stored a] -> Maybe (Stored a)
forall a. [a] -> Maybe a
listToMaybe ([Stored a] -> Maybe (Stored a))
-> ([Stored a] -> [Stored a]) -> [Stored a] -> Maybe (Stored a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stored a] -> [Stored a]
forall a. Storable a => [Stored a] -> [Stored a]
filterAncestors ([Stored a] -> [Stored a])
-> ([Stored a] -> [Stored a]) -> [Stored a] -> [Stored a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> Maybe b) -> Stored a -> [Stored a]
forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a]
findPropHeads a -> Maybe b
sel (Stored a -> [Stored a]) -> [Stored a] -> [Stored a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)

findPropHeads :: forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a]
findPropHeads :: forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a]
findPropHeads a -> Maybe b
sel Stored a
sobj | Just b
_ <- a -> Maybe b
sel (a -> Maybe b) -> a -> Maybe b
forall a b. (a -> b) -> a -> b
$ Stored a -> a
forall a. Stored a -> a
fromStored Stored a
sobj = [Stored a
sobj]
                       | Bool
otherwise = (a -> Maybe b) -> Stored a -> [Stored a]
forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a]
findPropHeads a -> Maybe b
sel (Stored a -> [Stored a]) -> [Stored a] -> [Stored a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stored a -> [Stored a]
forall a. Storable a => Stored a -> [Stored a]
previous Stored a
sobj