From 83d291f476a9793012a7aabb27c3cf59c7bdea05 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Tue, 11 Mar 2025 20:22:33 +0100
Subject: Generic type for MonadError constraints
Changelog: API: MonadError constraints use generic error type
---
src/Erebos/Object/Internal.hs | 48 ++++++++++++++++++++++---------------------
1 file changed, 25 insertions(+), 23 deletions(-)
(limited to 'src/Erebos/Object')
diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs
index 5d88ad0..4bca49c 100644
--- a/src/Erebos/Object/Internal.hs
+++ b/src/Erebos/Object/Internal.hs
@@ -79,6 +79,7 @@ import qualified Data.UUID as U
import System.IO.Unsafe
+import Erebos.Error
import Erebos.Storage.Internal
@@ -215,7 +216,7 @@ ioLoadObject ref@(Ref st rhash) = do
let chash = hashToRefDigest file
when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -}
return $ case runExcept $ unsafeDeserializeObject st file of
- Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -}
+ Left err -> error $ showErebosError err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -}
Right (x, rest) | BL.null rest -> x
| otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -}
@@ -223,7 +224,7 @@ lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.By
lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString)
lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref
-unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except String (Object' c, BL.ByteString)
+unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except ErebosError (Object' c, BL.ByteString)
unsafeDeserializeObject _ bytes | BL.null bytes = return (ZeroObject, bytes)
unsafeDeserializeObject st bytes =
case BLC.break (=='\n') bytes of
@@ -232,10 +233,10 @@ unsafeDeserializeObject st bytes =
guard $ B.length content == len
(,next) <$> case otype of
_ | otype == BC.pack "blob" -> return $ Blob content
- | otype == BC.pack "rec" -> maybe (throwError $ "Malformed record item ")
+ | otype == BC.pack "rec" -> maybe (throwOtherError $ "malformed record item ")
(return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content
| otherwise -> return $ UnknownObject otype content
- _ -> throwError $ "Malformed object"
+ _ -> throwOtherError $ "malformed object"
where splitObjPrefix line = do
[otype, tlen] <- return $ BLC.words line
(len, rest) <- BLC.readInt tlen
@@ -270,10 +271,10 @@ unsafeDeserializeObject st bytes =
_ -> Nothing
return (name, val)
-deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString)
+deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString)
deserializeObject = unsafeDeserializeObject
-deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject]
+deserializeObjects :: PartialStorage -> BL.ByteString -> Except ErebosError [PartialObject]
deserializeObjects _ bytes | BL.null bytes = return []
deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes
(obj:) <$> deserializeObjects st rest
@@ -344,11 +345,12 @@ newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString
type StoreRec c = StoreRecM c ()
-newtype Load a = Load (ReaderT (Ref, Object) (Except String) a)
- deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String)
+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) ++ ": ")++)) id $ runExcept $ runReaderT f (ref, lazyLoadObject ref)
+evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ") ++) . showErebosError) id $
+ runExcept $ runReaderT f (ref, lazyLoadObject ref)
loadCurrentRef :: Load Ref
loadCurrentRef = Load $ asks fst
@@ -356,8 +358,8 @@ loadCurrentRef = Load $ asks fst
loadCurrentObject :: Load Object
loadCurrentObject = Load $ asks snd
-newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a)
- deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String)
+newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except ErebosError) a)
+ deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError)
loadRecCurrentRef :: LoadRec Ref
loadRecCurrentRef = LoadRec $ asks fst
@@ -413,7 +415,7 @@ storeZero = StoreZero
class StorableText a where
toText :: a -> Text
- fromText :: MonadError String m => Text -> m a
+ fromText :: MonadError ErebosError m => Text -> m a
instance StorableText Text where
toText = id; fromText = return
@@ -526,23 +528,23 @@ storeRecItems items = StoreRecM $ do
loadBlob :: (ByteString -> a) -> Load a
loadBlob f = loadCurrentObject >>= \case
Blob x -> return $ f x
- _ -> throwError "Expecting blob"
+ _ -> throwOtherError "Expecting blob"
loadRec :: LoadRec a -> Load a
loadRec (LoadRec lrec) = loadCurrentObject >>= \case
Rec rs -> do
ref <- loadCurrentRef
either throwError return $ runExcept $ runReaderT lrec (ref, rs)
- _ -> throwError "Expecting record"
+ _ -> throwOtherError "Expecting record"
loadZero :: a -> Load a
loadZero x = loadCurrentObject >>= \case
ZeroObject -> return x
- _ -> throwError "Expecting zero"
+ _ -> throwOtherError "Expecting zero"
loadEmpty :: String -> LoadRec ()
-loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name
+loadEmpty name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name
loadMbEmpty :: String -> LoadRec (Maybe ())
loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems
@@ -553,7 +555,7 @@ loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems
p _ = Nothing
loadInt :: Num a => String -> LoadRec a
-loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name
+loadInt name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbInt name
loadMbInt :: Num a => String -> LoadRec (Maybe a)
loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems
@@ -564,7 +566,7 @@ loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems
p _ = Nothing
loadNum :: (Real a, Fractional a) => String -> LoadRec a
-loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name
+loadNum name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbNum name
loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a)
loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems
@@ -575,7 +577,7 @@ loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems
p _ = Nothing
loadText :: StorableText a => String -> LoadRec a
-loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name
+loadText name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbText name
loadMbText :: StorableText a => String -> LoadRec (Maybe a)
loadMbText name = listToMaybe <$> loadTexts name
@@ -589,7 +591,7 @@ loadTexts name = sequence . mapMaybe p =<< loadRecItems
p _ = Nothing
loadBinary :: BA.ByteArray a => String -> LoadRec a
-loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name
+loadBinary name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbBinary name
loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a)
loadMbBinary name = listToMaybe <$> loadBinaries name
@@ -603,7 +605,7 @@ loadBinaries name = mapMaybe p <$> loadRecItems
p _ = Nothing
loadDate :: StorableDate a => String -> LoadRec a
-loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name
+loadDate name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbDate name
loadMbDate :: StorableDate a => String -> LoadRec (Maybe a)
loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems
@@ -614,7 +616,7 @@ loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems
p _ = Nothing
loadUUID :: StorableUUID a => String -> LoadRec a
-loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name
+loadUUID name = maybe (throwOtherError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name
loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a)
loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems
@@ -625,7 +627,7 @@ loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems
p _ = Nothing
loadRawRef :: String -> LoadRec Ref
-loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name
+loadRawRef name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name
loadMbRawRef :: String -> LoadRec (Maybe Ref)
loadMbRawRef name = listToMaybe <$> loadRawRefs name
--
cgit v1.2.3