msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

errorful bleedOut

Browse Source
This commit is contained in:
crumbtoo
2024-03-27 11:26:45 -06:00
parent 807088e1db
commit b6a4f71706
1 changed files with 6 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/Control/Monad/Errorful.hs
View File

@@ -41,10 +41,15 @@ runErrorful m = coerce (runErrorfulT m)
class (Applicative m) => MonadErrorful e m | m -> e where class (Applicative m) => MonadErrorful e m | m -> e where
addWound :: e -> m () addWound :: e -> m ()
addFatal :: e -> m a addFatal :: e -> m a
-- | Turn any wounds into fatals
bleedOut :: m a -> m a
instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
addWound e = ErrorfulT $ pure (Just (), [e]) addWound e = ErrorfulT $ pure (Just (), [e])
addFatal e = ErrorfulT $ pure (Nothing, [e]) addFatal e = ErrorfulT $ pure (Nothing, [e])
bleedOut m = ErrorfulT $ runErrorfulT m <&> \case
(a, []) -> (a, [])
(_, es) -> (Nothing, es)
instance MonadTrans (ErrorfulT e) where instance MonadTrans (ErrorfulT e) where
lift m = ErrorfulT ((\x -> (Just x,[])) <$> m) lift m = ErrorfulT ((\x -> (Just x,[])) <$> m)
@@ -86,6 +91,7 @@ hoistErrorfulT nt (ErrorfulT m) = ErrorfulT (nt m)
instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where instance (Monad m, MonadErrorful e m) => MonadErrorful e (ReaderT r m) where
addWound = lift . addWound addWound = lift . addWound
addFatal = lift . addFatal addFatal = lift . addFatal
bleedOut = mapReaderT bleedOut
instance (Monad m, MonadState s m) => MonadState s (ErrorfulT e m) where instance (Monad m, MonadState s m) => MonadState s (ErrorfulT e m) where
state = lift . state state = lift . state