simple-effects 0.6.0.0 → 0.6.0.1

raw patch · 4 files changed

+69/−7 lines, 4 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• simple-effects.cabal +1/−1
• src/Control/Effects/Early.hs +1/−1
• src/Control/Effects/Signal.hs +51/−4
• test/Main.hs +16/−1

@@ -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

@@ -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))
 

@@ -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

@@ -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 ())