module Data.StableTree.Persist
( Error(..)
, Fragment(..)
, store
, store'
, load
, load'
) where
import Data.StableTree.Conversion ( Fragment(..), toFragments, fromFragments )
import Data.StableTree.Key ( StableKey )
import Data.StableTree.Types ( StableTree(..) )
import qualified Data.Map as Map
import Data.ObjectID ( ObjectID )
import Data.Serialize ( Serialize )
import Data.Text ( Text )
class Error e where
stableTreeError :: Text -> e
store :: (Monad m, Error e, Ord k, Serialize k, StableKey k, Serialize v)
=> (a -> ObjectID -> Fragment k v -> m (Either e a))
-> a
-> StableTree k v
-> m (Either e a)
store fn a0 = go a0 . toFragments
where
go accum [] = return $ Right accum
go accum (frag:frags) =
fn accum (fragmentObjectID frag) frag >>= \case
Left err -> return $ Left err
Right accum' -> go accum' frags
store' :: (Monad m, Error e, Ord k, Serialize k, StableKey k, Serialize v)
=> (ObjectID -> Fragment k v -> m (Maybe e))
-> StableTree k v
-> m (Either e ObjectID)
store' fn = store fn' undefined
where
fn' _accum oid frag =
fn oid frag >>= \case
Nothing -> return $ Right oid
Just err -> return $ Left err
load :: (Monad m, Error e, Ord k, Serialize k, StableKey k, Serialize v)
=> (a -> ObjectID -> m (Either e (a, Fragment k v)))
-> a
-> ObjectID
-> m (Either e (a, StableTree k v))
load fn a0 top =
recur a0 Map.empty [top] >>= \case
Left err ->
return $ Left err
Right (accum, frags) ->
case Map.lookup top frags of
Nothing ->
return $ Left (stableTreeError "load/recur failed to find top")
Just frag ->
case fromFragments frags frag of
Left err -> return $ Left (stableTreeError err)
Right t -> return $ Right (accum, t)
where
recur accum frags [] = return $ Right (accum, frags)
recur accum frags (oid:rest) = fn accum oid >>= \case
Left err -> return $ Left err
Right (accum', frag@(FragmentBottom{})) ->
recur accum' (Map.insert oid frag frags) rest
Right (accum', frag) ->
let children = fragmentChildren frag
oids = map snd $ Map.elems children
in recur accum' (Map.insert oid frag frags) (oids ++ rest)
load' :: (Monad m, Error e, Ord k, Serialize k, StableKey k, Serialize v)
=> (ObjectID -> m (Either e (Fragment k v)))
-> ObjectID
-> m (Either e (StableTree k v))
load' fn top =
load fn' undefined top >>= \case
Left err -> return $ Left err
Right (_, tree) -> return $ Right tree
where
fn' st oid =
fn oid >>= \case
Left err -> return $ Left err
Right frag -> return $ Right (st, frag)