1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
module Storage.Merge (
Mergeable(..),
merge, storeMerge,
Generation,
showGeneration,
compareGeneration, generationMax,
storedGeneration,
generations,
ancestors,
precedes,
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 Storage
import Storage.Internal
import 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 = id
toComponents = id
merge :: Mergeable a => [Stored (Component a)] -> a
merge [] = error "merge: empty list"
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
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
generations :: Storable a => [Stored a] -> [Set (Stored a)]
generations = unfoldr gen . (,S.empty)
where gen (hs, cur) = case filter (`S.notMember` cur) $ previous =<< hs of
[] -> Nothing
added -> let next = foldr S.insert cur added
in Just (next, (added, next))
ancestors :: Storable a => [Stored a] -> Set (Stored a)
ancestors = last . (S.empty:) . generations
precedes :: Storable a => Stored a -> Stored a -> Bool
precedes x y = not $ x `elem` filterAncestors [x, y]
filterAncestors :: Storable a => [Stored a] -> [Stored 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
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
|