1 files changed, 154 insertions, 0 deletions
diff --git a/src/Erebos/Storage/List.hs b/src/Erebos/Storage/List.hs
new file mode 100644
index 0000000..f0f8786
--- /dev/null
+++ b/src/Erebos/Storage/List.hs
@@ -0,0 +1,154 @@
+module Erebos.Storage.List (
+    StoredList,
+    emptySList, fromSList, storedFromSList,
+    slistAdd, slistAddS,
+    -- TODO slistInsert, slistInsertS,
+    slistRemove, slistReplace, slistReplaceS,
+    -- TODO mapFromSList, updateOld,
+
+    -- TODO StoreUpdate(..),
+    -- TODO withStoredListItem, withStoredListItemS,
+) where
+
+import Data.List
+import Data.Maybe
+import qualified Data.Set as S
+
+import Erebos.Storage
+import Erebos.Storage.Internal
+import Erebos.Storage.Merge
+
+data List a = ListNil
+            | 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' x@ListItem {} = storeRec $ do
+        mapM_ (storeRef "PREV") $ listPrev x
+        mapM_ (storeRef "item") $ listItem x
+        mapM_ (storeRef "remove") $ listRemove x
+
+    load' = loadCurrentObject >>= \case
+        ZeroObject -> return ListNil
+        _ -> loadRec $ ListItem <$> loadRefs "PREV"
+                                <*> loadMbRef "item"
+                                <*> loadMbRef "remove"
+
+instance Storable a => ZeroStorable (List a) where
+    fromZero _ = ListNil
+
+
+emptySList :: Storable a => Storage -> IO (StoredList a)
+emptySList st = wrappedStore st ListNil
+
+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 (Component a) -> [a]
+fromSList = map merge . groupsFromSLists
+
+storedFromSList :: (Mergeable a, Storable a) => StoredList (Component a) -> IO [Stored a]
+storedFromSList = mapM storeMerge . groupsFromSLists
+
+slistAdd :: Storable a => a -> StoredList a -> IO (StoredList a)
+slistAdd x prev@(Stored (Ref st _) _) = do
+    sx <- wrappedStore st x
+    slistAddS sx prev
+
+slistAddS :: Storable a => Stored a -> StoredList a -> IO (StoredList a)
+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 prev@(Stored (Ref st _) _) = do
+    sx <- wrappedStore st x
+    slistInsertS after sx prev
+
+slistInsertS :: Storable a => Stored a -> Stored a -> StoredList a -> IO (StoredList a)
+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 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 prev@(Stored (Ref st _) _) = do
+    sx <- wrappedStore st x
+    slistReplaceS rm sx prev
+
+slistReplaceS :: Storable a => Stored a -> Stored a -> StoredList a -> IO (StoredList a)
+slistReplaceS rm sx prev@(Stored (Ref st _) _) = wrappedStore st $ ListItem [prev] (Just sx) (findSListRef rm prev)
+
+findSListRef :: Stored a -> StoredList a -> Maybe (StoredList a)
+findSListRef _ (Stored _ ListNil) = Nothing
+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)
+          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
+-}