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.hs140
1 files changed, 72 insertions, 68 deletions
diff --git a/src/Storage/List.hs b/src/Storage/List.hs
index e58c339..e112b46 100644
--- a/src/Storage/List.hs
+++ b/src/Storage/List.hs
@@ -1,121 +1,124 @@
module Storage.List (
StoredList,
emptySList, fromSList, storedFromSList,
- slistAdd, slistAddS, slistInsert, slistInsertS, slistRemove, slistReplace, slistReplaceS,
- mapFromSList, updateOld,
+ slistAdd, slistAddS,
+ -- TODO slistInsert, slistInsertS,
+ slistRemove, slistReplace, slistReplaceS,
+ -- TODO mapFromSList, updateOld,
- StoreUpdate(..),
- withStoredListItem, withStoredListItemS,
+ -- TODO StoreUpdate(..),
+ -- TODO 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 qualified Data.Set as S
import Storage
import Storage.Internal
+import Storage.Merge
data List a = ListNil
- | ListItem (Maybe Ref) (Maybe Ref) (Maybe (Stored a)) (StoredList a)
- deriving (Show)
+ | ListItem { listPrev :: [StoredList a]
+ , listItem :: Maybe (Stored a)
+ , listRemove :: Maybe (Stored (List a))
+ }
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
+ store' x@ListItem {} = storeRec $ do
+ mapM_ (storeRef "PREV") $ listPrev x
+ mapM_ (storeRef "item") $ listItem x
+ mapM_ (storeRef "remove") $ listRemove x
load' = asks snd >>= \case
- ZeroObject -> return ListNil
- _ ->
- loadRec $ ListItem
- <$> loadMbRawRef "r"
- <*> loadMbRawRef "a"
- <*> loadMbRef "i"
- <*> loadRef "n"
+ ZeroObject -> return ListNil
+ _ -> loadRec $ ListItem <$> loadRefs "PREV"
+ <*> loadMbRef "item"
+ <*> loadMbRef "remove"
instance Storable a => ZeroStorable (List a) where
fromZero _ = ListNil
+instance Storable a => Mergeable (List a) where
+ mergeSorted xs = ListItem xs Nothing Nothing
+
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
+groupsFromSLists :: forall a. Storable a => StoredList a -> [[Stored a]]
+groupsFromSLists = helperSelect S.empty . (:[])
+ where
+ helperSelect :: S.Set (StoredList a) -> [StoredList a] -> [[Stored a]]
+ helperSelect rs xxs | x:xs <- sort $ filterRemoved rs xxs = helper rs x xs
+ | otherwise = []
+
+ helper :: S.Set (StoredList a) -> StoredList a -> [StoredList a] -> [[Stored a]]
+ helper rs x xs
+ | ListNil <- fromStored x
+ = []
+
+ | Just rm <- listRemove (fromStored x)
+ , ans <- ancestors [x]
+ , (other, collision) <- partition (S.null . S.intersection ans . ancestors . (:[])) xs
+ , cont <- helperSelect (rs `S.union` ancestors [rm]) $ concatMap (listPrev . fromStored) (x : collision) ++ other
+ = case catMaybes $ map (listItem . fromStored) (x : collision) of
+ [] -> cont
+ xis -> xis : cont
+
+ | otherwise = case listItem (fromStored x) of
+ Nothing -> helperSelect rs $ listPrev (fromStored x) ++ xs
+ Just xi -> [xi] : (helperSelect rs $ listPrev (fromStored x) ++ xs)
+
+ filterRemoved :: S.Set (StoredList a) -> [StoredList a] -> [StoredList a]
+ filterRemoved rs = filter (S.null . S.intersection rs . ancestors . (:[]))
+
+fromSList :: Mergeable a => StoredList a -> [a]
+fromSList = map merge . groupsFromSLists
+
+storedFromSList :: Mergeable a => StoredList a -> IO [Stored a]
+storedFromSList = mapM storeMerge . groupsFromSLists
slistAdd :: Storable a => a -> StoredList a -> IO (StoredList a)
-slistAdd x next@(Stored (Ref st _) _) = do
+slistAdd x prev@(Stored (Ref st _) _) = do
sx <- wrappedStore st x
- slistAddS sx next
+ slistAddS sx prev
slistAddS :: Storable a => Stored a -> StoredList a -> IO (StoredList a)
-slistAddS sx next@(Stored (Ref st _) _) = wrappedStore st (ListItem Nothing Nothing (Just sx) next)
+slistAddS sx prev@(Stored (Ref st _) _) = wrappedStore st (ListItem [prev] (Just sx) Nothing)
+{- TODO
slistInsert :: Storable a => Stored a -> a -> StoredList a -> IO (StoredList a)
-slistInsert after x next@(Stored (Ref st _) _) = do
+slistInsert after x prev@(Stored (Ref st _) _) = do
sx <- wrappedStore st x
- slistInsertS after sx next
+ slistInsertS after sx prev
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
+slistInsertS after sx prev@(Stored (Ref st _) _) = wrappedStore st $ ListItem Nothing (findSListRef after prev) (Just sx) prev
+-}
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
+slistRemove rm prev@(Stored (Ref st _) _) = wrappedStore st $ ListItem [prev] Nothing (findSListRef rm prev)
slistReplace :: Storable a => Stored a -> a -> StoredList a -> IO (StoredList a)
-slistReplace rm x next@(Stored (Ref st _) _) = do
+slistReplace rm x prev@(Stored (Ref st _) _) = do
sx <- wrappedStore st x
- slistReplaceS rm sx next
+ slistReplaceS rm sx prev
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
+slistReplaceS rm sx prev@(Stored (Ref st _) _) = wrappedStore st $ ListItem [prev] (Just sx) (findSListRef rm prev)
-findSListRef :: Stored a -> StoredList a -> Maybe Ref
+findSListRef :: Stored a -> StoredList a -> Maybe (StoredList a)
findSListRef _ (Stored _ ListNil) = Nothing
-findSListRef x (Stored ref (ListItem _ _ y next)) | y == Just x = Just ref
- | otherwise = findSListRef x next
+findSListRef x cur | listItem (fromStored cur) == Just x = Just cur
+ | otherwise = listToMaybe $ catMaybes $ map (findSListRef x) $ listPrev $ fromStored cur
+{- TODO
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)
@@ -153,3 +156,4 @@ withStoredListItemS p list f = do
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 17:10:43 +0000