Mergeable stored list

5 files changed, 112 insertions, 72 deletions

diff --git a/src/Main.hs b/src/Main.hs
index 890cdcd..93517b2 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -206,7 +206,8 @@ cmdSend = void $ do
     let powner = finalOwner pid :: ComposedIdentity
     text <- asks ciLine
     smsg <- liftIO $ updateLocalState st $ \erb -> do
-        (slist, smsg) <- case find (sameIdentity powner . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of
+        threads <- storedFromSList $ lsMessages $ fromStored erb
+        (slist, smsg) <- case find (sameIdentity powner . msgPeer . fromStored) threads of
             Just thread -> do
                 (smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text)
                 (,smsg) <$> slistReplaceS thread thread' (lsMessages $ fromStored erb)
diff --git a/src/Message.hs b/src/Message.hs
index 61d882c..21f398c 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -12,6 +12,7 @@ import Data.Time.LocalTime
 
 import Identity
 import Storage
+import Storage.Merge
 
 data DirectMessage = DirectMessage
     { msgFrom :: ComposedIdentity
@@ -29,13 +30,13 @@ data DirectMessageThread = DirectMessageThread
 instance Storable DirectMessage where
     store' msg = storeRec $ do
         mapM_ (storeRef "from") $ idDataF $ msgFrom msg
-        mapM_ (storeRef "prev") $ msgPrev msg
+        mapM_ (storeRef "PREV") $ msgPrev msg
         storeDate "time" $ msgTime msg
         storeText "text" $ msgText msg
 
     load' = loadRec $ DirectMessage
         <$> loadIdentity "from"
-        <*> loadRefs "prev"
+        <*> loadRefs "PREV"
         <*> loadDate "time"
         <*> loadText "text"
 
@@ -50,6 +51,13 @@ instance Storable DirectMessageThread where
         <*> loadRefs "head"
         <*> loadRefs "seen"
 
+instance Mergeable DirectMessageThread where
+    mergeSorted ts = DirectMessageThread
+        { msgPeer = msgPeer $ fromStored $ head ts -- TODO: merge identity
+        , msgHead = filterAncestors $ msgHead . fromStored =<< ts
+        , msgSeen = filterAncestors $ msgSeen . fromStored =<< ts
+        }
+
 
 emptyDirectThread :: ComposedIdentity -> DirectMessageThread
 emptyDirectThread peer = DirectMessageThread peer [] []
diff --git a/src/Message/Service.hs b/src/Message/Service.hs
index 044b882..1311e24 100644
--- a/src/Message/Service.hs
+++ b/src/Message/Service.hs
@@ -32,7 +32,8 @@ instance Service DirectMessageService where
            -> do erb <- gets svcLocal
                  let st = storedStorage erb
                  erb' <- liftIO $ do
-                     slist <- case find (sameIdentity powner . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of
+                     threads <- storedFromSList $ lsMessages $ fromStored erb
+                     slist <- case find (sameIdentity powner . msgPeer . fromStored) threads of
                                    Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) }
                                                      slistReplaceS thread thread' $ lsMessages $ fromStored erb
                                    Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ lsMessages $ fromStored erb
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
+-}
diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs
index ac80c96..74b88d7 100644
--- a/src/Storage/Merge.hs
+++ b/src/Storage/Merge.hs
@@ -1,7 +1,12 @@
 module Storage.Merge (
+    Mergeable(..),
+    merge, storeMerge,
+    uniq,
+
     generations,
     ancestors,
     precedes,
+    filterAncestors,
 ) where
 
 import qualified Data.ByteString.Char8 as BC
@@ -13,6 +18,24 @@ import qualified Data.Set as S
 import Storage
 import Storage.Internal
 
+class Storable a => Mergeable a where
+    mergeSorted :: [Stored a] -> a
+
+merge :: Mergeable a => [Stored a] -> a
+merge [] = error "merge: empty list"
+merge [x] = fromStored x
+merge xs = mergeSorted $ filterAncestors xs
+
+storeMerge :: Mergeable a => [Stored a] -> IO (Stored a)
+storeMerge [] = error "merge: empty list"
+storeMerge [x] = return x
+storeMerge xs@(Stored ref _ : _) = wrappedStore (refStorage ref) $ mergeSorted $ filterAncestors xs
+
+uniq :: Eq a => [a] -> [a]
+uniq (x:x':xs) | x == x'   = uniq (x:xs)
+               | otherwise = x : uniq (x':xs)
+uniq xs = 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
@@ -38,3 +61,6 @@ ancestors = last . (S.empty:) . generations
 
 precedes :: Storable a => Stored a -> Stored a -> Bool
 precedes x y = x `S.member` ancestors [y]
+
+filterAncestors :: Storable a => [Stored a] -> [Stored a]
+filterAncestors xs = uniq $ sort $ filter (`S.notMember` ancestors xs) xs