diff options
Diffstat (limited to 'src/Storage/Merge.hs')
| -rw-r--r-- | src/Storage/Merge.hs | 156 |
1 files changed, 0 insertions, 156 deletions
diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs deleted file mode 100644 index 7c6992f..0000000 --- a/src/Storage/Merge.hs +++ /dev/null @@ -1,156 +0,0 @@ -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 |