diff --git a/simple-effects.cabal b/simple-effects.cabal --- a/simple-effects.cabal +++ b/simple-effects.cabal @@ -1,5 +1,5 @@ name: simple-effects -version: 0.6.0.0 +version: 0.6.0.1 synopsis: A simple effect system that integrates with MTL description: Please see README.md homepage: https://gitlab.com/LukaHorvat/simple-effects diff --git a/src/Control/Effects/Early.hs b/src/Control/Effects/Early.hs --- a/src/Control/Effects/Early.hs +++ b/src/Control/Effects/Early.hs @@ -14,7 +14,7 @@ effect _ = throwE -- | Allows you to return early from a function. Make sure you 'handleEarly' to get the actual --- result out +-- result out. earlyReturn :: forall a b m. MonadEffect (Early a) m => a -> m b earlyReturn = fmap absurd . effect (Proxy :: Proxy (Early a)) diff --git a/src/Control/Effects/Signal.hs b/src/Control/Effects/Signal.hs --- a/src/Control/Effects/Signal.hs +++ b/src/Control/Effects/Signal.hs @@ -5,7 +5,8 @@ module Control.Effects.Signal ( MonadEffectSignal(..), ResumeOrBreak(..), throwSignal, handleSignal , Throws, handleException, handleToEither, module Control.Effects - , module Control.Monad.Trans.Except, MaybeT(..), discardAllExceptions, showAllExceptions ) where + , module Control.Monad.Trans.Except, MaybeT(..), discardAllExceptions, showAllExceptions + , Handles(..), handleToEitherRecursive ) where import Interlude hiding (TypeError) import Control.Monad.Trans.Except @@ -13,6 +14,7 @@ import qualified GHC.TypeLits as TL import GHC.TypeLits (TypeError, ErrorMessage(..)) import Control.Effects +import Control.Monad.Trans.Control data Signal a b type instance EffectMsg (Signal a b) = a @@ -40,10 +42,10 @@ effect = undefined -- | This class allows you to "throw" a signal. For the most part signals are the same as checked -- exceptions. The difference here is that the handler has the option to provide the value that --- will be the result _of calling the signal function_. This effectibvely allows you to have +-- will be the result /of calling the 'signal' function/. This effectively allows you to have -- recoverable exceptions at the call site, instead of just at the handling site. -- --- This class can be considered an alias for @MonadEffect (Signal a b)@ so your code isn't +-- This class can be considered an alias for @'MonadEffect' ('Signal' a b)@ so your code isn't -- required to provide any instances. class MonadEffect (Signal a b) m => MonadEffectSignal a b m where -- | There are no restrictions on the type of values that can be thrown or returned. @@ -110,7 +112,52 @@ mapLeft f (Left a) = Left (f a) mapLeft _ (Right b) = Right b --- | Satisfies all the 'Throws' and 'MonadEffectSignal' constraints _if_ they all throw 'Show'able +-- | Satisfies all the 'Throws' and 'MonadEffectSignal' constraints /if/ they all throw 'Show'able -- exceptions. The first thrown exception will be shown and returned as a 'Left' result. showAllExceptions :: Functor m => ExceptT SomeSignal m a -> m (Either Text a) showAllExceptions = fmap (mapLeft getSomeSignal) . runExceptT + +-- | A class of monads that throw and catch exceptions of type @e@. An overlappable instance is +-- given so you just need to make sure your transformers have a 'MonadTransControl' instance. +class Throws e m => Handles e m where + -- | Use this function to handle exceptions without discarding the 'Throws' constraint. + -- You'll want to use this if you're writing a recursive function. Using the regular handlers + -- in that case will result with infinite types. + -- + -- Since this function doesn't discard constraints, you still need to handle the whole thing. + -- + -- Here's a slightly contrived example. + -- + -- @ + -- data NotFound = NotFound + -- data Tree a = Leaf a | Node (Tree a) (Tree a) + -- data Step = GoLeft | GoRight + -- findIndex :: (Handles NotFound m, Eq a) => a -> Tree a -> m [Step] + -- findIndex x (Leaf a) | x == a = return [] + -- | otherwise = throwSignal NotFound + -- findIndex x (Node l r) = ((GoLeft :) <$> findIndex x l) + -- & handleRecursive (\NotFound -> (GoRight :) <$> findIndex x r) + -- @ + -- + -- Note: When you finally handle the exception effect, the order in which you handle it and + -- other effects determines whether 'handleRecursive' rolls back other effects if an exception + -- occured or it preserves all of them up to the point of the exception. + -- Handling exceptions last and handling them first will produce the former and latter + -- behaviour respectively. + handleRecursive :: (e -> m a) -> m a -> m a + +instance Monad m => Handles e (ExceptT e m) where + handleRecursive f = ExceptT . (either (runExceptT . f) (return . Right) <=< runExceptT) + {-# INLINE handleRecursive #-} + +instance {-# OVERLAPPABLE #-} (Monad m, Monad (t m), Handles e m, MonadTransControl t) + => Handles e (t m) where + handleRecursive f e = do + st <- liftWith (\run -> handleRecursive (run . f) (run e)) + restoreT (return st) + {-# INLINE handleRecursive #-} + +-- | 'handleToEither' that doesn't discard 'Throws' constraints. See documentation for +-- 'handleRecursive'. +handleToEitherRecursive :: Handles e m => m a -> m (Either e a) +handleToEitherRecursive = handleRecursive (return . Left) . fmap Right diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,6 +4,7 @@ import Interlude import Control.Effects.Signal +import Control.Effects.State -- Should infer ex1 = signal True @@ -18,5 +19,19 @@ handleException (\(b :: Bool) -> return ()) ex2 handleSignal (\(_ :: Bool) -> Resume 5) ex1 +orderTest :: (Test Bool m, MonadEffectState Int m, MonadIO m) => m () +orderTest = do + setState (1 :: Int) + _ :: Either Bool () <- handleE $ do + setState (2 :: Int) + void $ throwSignal True + setState (3 :: Int) + st :: Int <- getState + print st + main :: IO () -main = return () +main = do + orderTest & handleException (\(_ :: Bool) -> return ()) + & handleStateT (0 :: Int) + orderTest & handleStateT (0 :: Int) + & handleException (\(_ :: Bool) -> return ())