summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Erebos/Object/Internal.hs9
-rw-r--r--src/Erebos/Storable/Internal.hs5
2 files changed, 10 insertions, 4 deletions
diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs
index b624d1c..778f80a 100644
--- a/src/Erebos/Object/Internal.hs
+++ b/src/Erebos/Object/Internal.hs
@@ -30,7 +30,7 @@ module Erebos.Object.Internal (
storeRecItems,
Load, LoadRec,
- evalLoad,
+ evalLoad, evalLoadWithObject,
loadCurrentRef, loadCurrentObject,
loadRecCurrentRef, loadRecItems,
@@ -454,8 +454,11 @@ newtype Load a = Load (ReaderT (Ref, Object) (Except ErebosError) a)
deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError)
evalLoad :: Load a -> Ref -> a
-evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ") ++) . showErebosError) id $
- runExcept $ runReaderT f (ref, lazyLoadObject ref)
+evalLoad act ref = evalLoadWithObject act ref (lazyLoadObject ref)
+
+evalLoadWithObject :: Load a -> Ref -> Object -> a
+evalLoadWithObject (Load f) ref obj = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ") ++) . showErebosError) id $
+ runExcept $ runReaderT f ( ref, obj )
loadCurrentRef :: Load Ref
loadCurrentRef = Load $ asks fst
diff --git a/src/Erebos/Storable/Internal.hs b/src/Erebos/Storable/Internal.hs
index 4ab48a5..70b5fdc 100644
--- a/src/Erebos/Storable/Internal.hs
+++ b/src/Erebos/Storable/Internal.hs
@@ -5,7 +5,7 @@ module Erebos.Storable.Internal (
Stored(..),
fromStored, storedRef,
storedStorage,
- wrappedStore, wrappedLoad,
+ wrappedStore, wrappedLoad, loadFromObject,
copyStored,
unsafeMapStored,
@@ -61,6 +61,9 @@ wrappedStore st x = do ref <- liftIO $ store st x
wrappedLoad :: Storable a => Ref -> Stored a
wrappedLoad ref = Stored ref (load ref)
+loadFromObject :: Storable a => Stored Object -> Stored a
+loadFromObject (Stored ref obj) = Stored ref (evalLoadWithObject load' ref obj)
+
copyStored :: forall m a. MonadIO m => Storage -> Stored a -> m (Stored a)
copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (\r -> Stored r x) <$> copyRef' st ref'