diff options
Diffstat (limited to 'src/Storage')
| -rw-r--r-- | src/Storage/List.hs | 155 |
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 |