summaryrefslogtreecommitdiff
path: root/src/Storage/List.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Storage/List.hs')
-rw-r--r--src/Storage/List.hs155
1 files changed, 155 insertions, 0 deletions
diff --git a/src/Storage/List.hs b/src/Storage/List.hs
new file mode 100644
index 0000000..e58c339
--- /dev/null
+++ b/src/Storage/List.hs
@@ -0,0 +1,155 @@
+module Storage.List (
+ StoredList,
+ emptySList, fromSList, storedFromSList,
+ slistAdd, slistAddS, slistInsert, slistInsertS, slistRemove, slistReplace, slistReplaceS,
+ mapFromSList, updateOld,
+
+ StoreUpdate(..),
+ withStoredListItem, withStoredListItemS,
+) where
+
+import Control.Monad
+import Control.Monad.Reader
+
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+
+import Storage
+import Storage.Internal
+
+data List a = ListNil
+ | ListItem (Maybe Ref) (Maybe Ref) (Maybe (Stored a)) (StoredList a)
+ deriving (Show)
+
+type StoredList a = Stored (List a)
+
+instance Storable a => Storable (List a) where
+ store' ListNil = storeZero
+ store' (ListItem remove after item next) = storeRec $ do
+ storeMbRawRef "r" remove
+ storeMbRawRef "a" after
+ storeMbRef "i" item
+ storeRef "n" next
+
+ load' = asks snd >>= \case
+ ZeroObject -> return ListNil
+ _ ->
+ loadRec $ ListItem
+ <$> loadMbRawRef "r"
+ <*> loadMbRawRef "a"
+ <*> loadMbRef "i"
+ <*> loadRef "n"
+
+instance Storable a => ZeroStorable (List a) where
+ fromZero _ = ListNil
+
+
+emptySList :: Storable a => Storage -> IO (StoredList a)
+emptySList st = wrappedStore st ListNil
+
+fromSList :: StoredList a -> [a]
+fromSList = map fromStored . storedFromSList
+
+storedFromSList :: StoredList a -> [Stored a]
+storedFromSList = fromSList' []
+ where fromSList' :: [(Ref, Bool, [Stored a])] -> StoredList a -> [Stored a]
+ fromSList' _ (Stored _ ListNil) = []
+ fromSList' repl (Stored cref (ListItem rref aref x rest)) =
+ case (rref, aref) of
+ (Nothing, Nothing) -> let (rx, repl') = findRepl cref x repl
+ in rx ++ fromSList' repl' rest
+ (Just r , Nothing) -> fromSList' (addReplace cref r x repl) rest
+ (Nothing, Just a ) -> fromSList' (addInsert cref a x repl) rest
+ (Just r , Just a ) -> fromSList' (addReplace cref r x $ addInsert cref a x repl) rest
+
+ addReplace = findAddRepl False
+ addInsert = findAddRepl True
+
+ findAddRepl :: Bool -> Ref -> Ref -> Maybe (Stored a) -> [(Ref, Bool, [Stored a])] -> [(Ref, Bool, [Stored a])]
+ findAddRepl keep c t x rs = let (x', rs') = findRepl c x rs
+ in addRepl keep c t x' rs'
+
+ addRepl :: Bool -> Ref -> Ref -> [Stored a] -> [(Ref, Bool, [Stored a])] -> [(Ref, Bool, [Stored a])]
+ addRepl keep _ t x [] = [(t, keep, x)]
+ addRepl keep c t x ((pr, pk, px) : rs)
+ | pr == c = (t , keep, x ++ px) : rs
+ | pr == t = (t , pk, px ++ x) : rs
+ | otherwise = (pr, pk, px) : addRepl keep c t x rs
+
+ findRepl :: Ref -> Maybe (Stored a) -> [(Ref, Bool, [Stored a])] -> ([Stored a], [(Ref, Bool, [Stored a])])
+ findRepl _ x [] = (maybeToList x, [])
+ findRepl c x ((pr, pk, px) : rs)
+ | pr == c = (if pk then maybe id (:) x px else px, rs)
+ | otherwise = ((pr, pk, px):) <$> findRepl c x rs
+
+slistAdd :: Storable a => a -> StoredList a -> IO (StoredList a)
+slistAdd x next@(Stored (Ref st _) _) = do
+ sx <- wrappedStore st x
+ slistAddS sx next
+
+slistAddS :: Storable a => Stored a -> StoredList a -> IO (StoredList a)
+slistAddS sx next@(Stored (Ref st _) _) = wrappedStore st (ListItem Nothing Nothing (Just sx) next)
+
+slistInsert :: Storable a => Stored a -> a -> StoredList a -> IO (StoredList a)
+slistInsert after x next@(Stored (Ref st _) _) = do
+ sx <- wrappedStore st x
+ slistInsertS after sx next
+
+slistInsertS :: Storable a => Stored a -> Stored a -> StoredList a -> IO (StoredList a)
+slistInsertS after sx next@(Stored (Ref st _) _) = wrappedStore st $ ListItem Nothing (findSListRef after next) (Just sx) next
+
+slistRemove :: Storable a => Stored a -> StoredList a -> IO (StoredList a)
+slistRemove rm next@(Stored (Ref st _) _) = wrappedStore st $ ListItem (findSListRef rm next) Nothing Nothing next
+
+slistReplace :: Storable a => Stored a -> a -> StoredList a -> IO (StoredList a)
+slistReplace rm x next@(Stored (Ref st _) _) = do
+ sx <- wrappedStore st x
+ slistReplaceS rm sx next
+
+slistReplaceS :: Storable a => Stored a -> Stored a -> StoredList a -> IO (StoredList a)
+slistReplaceS rm sx next@(Stored (Ref st _) _) = wrappedStore st $ ListItem (findSListRef rm next) Nothing (Just sx) next
+
+findSListRef :: Stored a -> StoredList a -> Maybe Ref
+findSListRef _ (Stored _ ListNil) = Nothing
+findSListRef x (Stored ref (ListItem _ _ y next)) | y == Just x = Just ref
+ | otherwise = findSListRef x next
+
+mapFromSList :: Storable a => StoredList a -> Map RefDigest (Stored a)
+mapFromSList list = helper list M.empty
+ where helper :: Storable a => StoredList a -> Map RefDigest (Stored a) -> Map RefDigest (Stored a)
+ helper (Stored _ ListNil) cur = cur
+ helper (Stored _ (ListItem (Just rref) _ (Just x) rest)) cur =
+ let rxref = case load rref of
+ ListItem _ _ (Just rx) _ -> sameType rx x $ storedRef rx
+ _ -> error "mapFromSList: malformed list"
+ in helper rest $ case M.lookup (refDigest $ storedRef x) cur of
+ Nothing -> M.insert (refDigest rxref) x cur
+ Just x' -> M.insert (refDigest rxref) x' cur
+ helper (Stored _ (ListItem _ _ _ rest)) cur = helper rest cur
+ sameType :: a -> a -> b -> b
+ sameType _ _ x = x
+
+updateOld :: Map RefDigest (Stored a) -> Stored a -> Stored a
+updateOld m x = fromMaybe x $ M.lookup (refDigest $ storedRef x) m
+
+
+data StoreUpdate a = StoreKeep
+ | StoreReplace a
+ | StoreRemove
+
+withStoredListItem :: (Storable a) => (a -> Bool) -> StoredList a -> (a -> IO (StoreUpdate a)) -> IO (StoredList a)
+withStoredListItem p list f = withStoredListItemS (p . fromStored) list (suMap (wrappedStore $ storedStorage list) <=< f . fromStored)
+ where suMap :: Monad m => (a -> m b) -> StoreUpdate a -> m (StoreUpdate b)
+ suMap _ StoreKeep = return StoreKeep
+ suMap g (StoreReplace x) = return . StoreReplace =<< g x
+ suMap _ StoreRemove = return StoreRemove
+
+withStoredListItemS :: (Storable a) => (Stored a -> Bool) -> StoredList a -> (Stored a -> IO (StoreUpdate (Stored a))) -> IO (StoredList a)
+withStoredListItemS p list f = do
+ case find p $ storedFromSList list of
+ Just sx -> f sx >>= \case StoreKeep -> return list
+ StoreReplace nx -> slistReplaceS sx nx list
+ StoreRemove -> slistRemove sx list
+ Nothing -> return list
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 16:49:19 +0000