Rename Exception to Error and add some more effect handlers

bench/Core.hs

@@ -35,7 +35,7 @@ import Criterion.Main (defaultMain)
 
 import Control.Monad.Freer (Member, Eff, run, send)
 import Control.Monad.Freer.Internal (Eff(E, Val), decomp, qApp, tsingleton)
-import Control.Monad.Freer.Exception (runError, throwError)
+import Control.Monad.Freer.Error (runError, throwError)
 import Control.Monad.Freer.State (get, put, runState)
 import Control.Monad.Freer.StateRW (ask, tell, runStateR)
 

changelog.md

@@ -51,7 +51,7 @@ All notable changes to this project will be documented in this file.
 * Add `evalState` and `execState` convenience functions
   [freer!14](https://gitlab.com/queertypes/freer/merge_requests/14)
 * Data constructors of `Yield`, `CutFalse`, `Fresh`, `State` and `Trace`
-  are now exposed in addition to `Exc`, `Reader` and `Writer`
+  are now exposed in addition to `Error`, `Reader` and `Writer`
 * Generalised type signature of `asks`.
   [#7](https://github.com/IxpertaSolutions/freer-effects/issues/7)
 * Renamed modules `Data.Open.Union.*` to `Data.OpenUnion.*`.

examples/src/Console.hs

@@ -30,7 +30,7 @@ import System.Exit (exitSuccess)
 import System.IO (IO, getLine, putStrLn)
 
 import Control.Monad.Freer (Eff, LastMember, Member, interpretM, reinterpret3, run, runM, send)
-import Control.Monad.Freer.Exception (Exc, runError, throwError)
+import Control.Monad.Freer.Error (Error, runError, throwError)
 import Control.Monad.Freer.State (State, get, put, runState)
 import Control.Monad.Freer.Writer (Writer, runWriter, tell)
 
@@ -68,7 +68,7 @@ runConsolePure :: [String] -> Eff '[Console] w -> [String]
 runConsolePure inputs req = snd . fst $
     run (runWriter (runState (runError (reinterpret3 go req)) inputs))
   where
-    go :: Console v -> Eff '[Exc (), State [String], Writer [String]] v
+    go :: Console v -> Eff '[Error (), State [String], Writer [String]] v
     go (PutStrLn msg) = tell [msg]
     go GetLine = get >>= \case
       [] -> error "not enough lines"
@@ -99,7 +99,7 @@ runConsolePureM inputs req = do
     pure (either (const Nothing) Just x, inputs', output)
   where
     go :: Console v
-       -> Eff (Exc () ': State [String] ': Writer [String] ': effs) v
+       -> Eff (Error () ': State [String] ': Writer [String] ': effs) v
     go (PutStrLn msg) = tell [msg]
     go GetLine = get >>= \case
       [] -> error "not enough lines"

examples/src/Cut.hs

@@ -6,7 +6,7 @@ module Cut () where
 
 {-
 -- The signature is inferred
-tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int
+tcut1 :: (Member Choose r, Member (Error CutFalse) r) => Eff r Int
 tcut1 = (return (1::Int) `mplus'` return 2) `mplus'`
          ((cutfalse `mplus'` return 4) `mplus'`
           return 5)

freer-effects.cabal

@@ -1,4 +1,4 @@
--- This file has been generated from package.yaml by hpack version 0.17.0.
+-- This file has been generated from package.yaml by hpack version 0.18.1.
 --
 -- see: https://github.com/sol/hpack
 
@@ -68,7 +68,7 @@ library
       Control.Monad.Freer
       Control.Monad.Freer.Coroutine
       Control.Monad.Freer.Cut
-      Control.Monad.Freer.Exception
+      Control.Monad.Freer.Error
       Control.Monad.Freer.Fresh
       Control.Monad.Freer.Internal
       Control.Monad.Freer.NonDet
@@ -80,6 +80,8 @@ library
       Data.FTCQueue
       Data.OpenUnion
       Data.OpenUnion.Internal
+  other-modules:
+      Paths_freer_effects
   default-language: Haskell2010
 
 executable freer-examples

src/Control/Monad/Freer.hs

@@ -22,7 +22,7 @@ module Control.Monad.Freer
   , Members
   , LastMember
 
-    -- ** Sending Arbitrary Effect
+    -- ** Sending Arbitrary Effects
   , send
   , sendM
 
@@ -30,28 +30,35 @@ module Control.Monad.Freer
   , raise
 
     -- * Handling Effects
-  , Arr
   , run
   , runM
 
     -- ** Building Effect Handlers
+    -- *** Basic effect handlers
   , interpret
+  , interpose
+    -- *** Derived effect handlers
   , reinterpret
   , reinterpret2
   , reinterpret3
   , reinterpretN
   , translate
+    -- *** Monadic effect handlers
   , interpretM
+    -- *** Advanced effect handlers
+  , interpretWith
+  , interposeWith
   ) where
 
+import qualified Control.Monad.Freer.Internal as Internal
+
 import Control.Applicative (pure)
 import Control.Monad (Monad, (>>=))
 import Control.Natural (type (~>))
 import Data.Function ((.))
 
 import Control.Monad.Freer.Internal
-  ( Arr
-  , Eff
+  ( Eff
   , LastMember
   , Member
   , Members
@@ -72,7 +79,12 @@ import Control.Monad.Freer.Internal
 -- effects @effs@, produces a natural transformation from @'Eff' (eff ': effs)@
 -- to @'Eff' effs@.
 interpret :: (eff ~> Eff effs) -> Eff (eff ': effs) ~> Eff effs
-interpret f = handleRelay pure (\e -> (f e >>=))
+interpret f = interpretWith (\e -> (f e >>=))
+
+-- | Like 'interpret', but instead of handling the effect, allows responding to
+-- the effect while leaving it unhandled.
+interpose :: Member eff effs => (eff ~> Eff effs) -> Eff effs ~> Eff effs
+interpose f = interposeWith (\e -> (f e >>=))
 
 -- | Like 'interpret', but instead of removing the interpreted effect @f@,
 -- reencodes it in some new effect @g@.
@@ -120,7 +132,7 @@ reinterpretN f = replaceRelayN @gs pure (\e -> (f e >>=))
 translate :: (f ~> g) -> Eff (f ': effs) ~> Eff (g ': effs)
 translate f = reinterpret (send . f)
 
--- | Like 'interpret', this function runs an effect without introducting another
+-- | Like 'interpret', this function runs an effect without introducing another
 -- one. Like 'translate', this function runs an effect by translating it into
 -- another effect in isolation, without access to the other effects in @effs@.
 -- Unlike either of those functions, however, this runs the effect in a final
@@ -133,3 +145,33 @@ interpretM
   :: (Monad m, LastMember m effs)
   => (eff ~> m) -> Eff (eff ': effs) ~> Eff effs
 interpretM f = interpret (sendM . f)
+
+-- | A highly general way of handling an effect. Like 'interpret', but
+-- explicitly passes the /continuation/, a function of type @v -> 'Eff' effs b@,
+-- to the handler function. Most handlers invoke this continuation to resume the
+-- computation with a particular value as the result, but some handlers may
+-- return a value without resumption, effectively aborting the computation to
+-- the point where the handler is invoked. This is useful for implementing
+-- things like 'Control.Monad.Freer.Error.catchError', for example.
+--
+-- @
+-- 'interpret' f = 'interpretWith' (\e -> (f e '>>='))
+-- @
+interpretWith
+  :: (forall v. eff v -> (v -> Eff effs b) -> Eff effs b)
+  -> Eff (eff ': effs) b
+  -> Eff effs b
+interpretWith = handleRelay pure
+
+-- | Combines the interposition behavior of 'interpose' with the
+-- continuation-passing capabilities of 'interpretWith'.
+--
+-- @
+-- 'interpose' f = 'interposeWith' (\e -> (f e '>>='))
+-- @
+interposeWith
+  :: Member eff effs
+  => (forall v. eff v -> (v -> Eff effs b) -> Eff effs b)
+  -> Eff effs b
+  -> Eff effs b
+interposeWith = Internal.interpose pure

src/Control/Monad/Freer/Cut.hs

@@ -11,7 +11,7 @@
 -- Stability:    broken
 -- Portability:  GHC specific language extensions.
 --
--- Composable handler for logical Cut effects. Implemented in terms of 'Exc'
+-- Composable handler for logical Cut effects. Implemented in terms of 'Error'
 -- effect.
 --
 -- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
@@ -23,23 +23,23 @@ module Control.Monad.Freer.Cut
   where
 
 -- import Control.Monad
-import Control.Monad.Freer.Exception (Exc, throwError)
+import Control.Monad.Freer.Error (Error, throwError)
 import Control.Monad.Freer.Internal (Eff, Member)
 
 
 data CutFalse = CutFalse
 -- data Choose a b = Choose [a] b
 
--- | Implementation of logical Cut using Exc effects.
-cutFalse :: Member (Exc CutFalse) r => Eff r a
+-- | Implementation of logical Cut using Error effects.
+cutFalse :: Member (Error CutFalse) r => Eff r a
 cutFalse = throwError CutFalse
 
 {-
-call :: Member (Exc CutFalse) r => Eff (Exc CutFalse ': r) a -> Eff r a
+call :: Member (Error CutFalse) r => Eff (Error CutFalse ': r) a -> Eff r a
 call m = loop [] m where
  loop jq (Val x) = return x `mplus` next jq          -- (C2)
  loop jq (E u q) = case decomp u of
-    Right (Exc CutFalse) -> mzero  -- drop jq (F2)
+    Right (Error CutFalse) -> mzero  -- drop jq (F2)
     Left u -> check jq u
 
  check jq u | Just (Choose [] _) <- prj u  = next jq  -- (C1)

src/Control/Monad/Freer/Error.hs

@@ -3,23 +3,24 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TypeOperators #-}
 -- |
--- Module:       Control.Monad.Freer.Exception
--- Description:  An Exception effect and handler.
+-- Module:       Control.Monad.Freer.Error
+-- Description:  An Error effect and handler.
 -- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.
 -- License:      BSD3
 -- Maintainer:   ixcom-core@ixperta.com
 -- Stability:    experimental
 -- Portability:  GHC specific language extensions.
 --
--- Composable handler for Exception effects. Communicates success\/failure
--- via an 'Either' type.
+-- Composable handler for Error effects. Communicates success\/failure via an
+-- 'Either' type.
 --
 -- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
-module Control.Monad.Freer.Exception
-    ( Exc(..)
+module Control.Monad.Freer.Error
+    ( Error(..)
     , throwError
     , runError
     , catchError
+    , handleError
     )
   where
 
@@ -35,22 +36,29 @@ import Control.Monad.Freer.Internal (Eff, Member, handleRelay, interpose, send)
 --------------------------------------------------------------------------------
 
 -- | Exceptions of the type @e :: *@ with no resumption.
-newtype Exc e a = Exc e
+newtype Error e a = Error e
 
 -- | Throws an error carrying information of type @e :: *@.
-throwError :: Member (Exc e) effs => e -> Eff effs a
-throwError e = send (Exc e)
+throwError :: Member (Error e) effs => e -> Eff effs a
+throwError e = send (Error e)
 
 -- | Handler for exception effects. If there are no exceptions thrown, returns
 -- 'Right'. If exceptions are thrown and not handled, returns 'Left', while
 -- interrupting the execution of any other effect handlers.
-runError :: Eff (Exc e ': effs) a -> Eff effs (Either e a)
-runError = handleRelay (pure . Right) (\(Exc e) _k -> pure (Left e))
+runError :: Eff (Error e ': effs) a -> Eff effs (Either e a)
+runError = handleRelay (pure . Right) (\(Error e) _k -> pure (Left e))
 
 -- | A catcher for Exceptions. Handlers are allowed to rethrow exceptions.
 catchError
-    :: Member (Exc e) effs
+  :: Member (Error e) effs
   => Eff effs a
   -> (e -> Eff effs a)
   -> Eff effs a
-catchError m handle = interpose pure (\(Exc e) _k -> handle e) m
+catchError m handle = interpose pure (\(Error e) _ -> handle e) m
+
+-- | A catcher for Exceptions. Handlers are /not/ allowed to rethrow exceptions.
+handleError
+  :: Eff (Error e ': effs) a
+  -> (e -> Eff effs a)
+  -> Eff effs a
+handleError m handle = handleRelay pure (\(Error e) _ -> handle e) m

tests/Tests/Exception.hs

@@ -24,14 +24,14 @@ import Test.Tasty.HUnit (testCase, (@?=))
 import Test.Tasty.QuickCheck (testProperty)
 
 import Control.Monad.Freer (Eff, Member, Members, run)
-import Control.Monad.Freer.Exception (Exc, catchError, runError, throwError)
+import Control.Monad.Freer.Error (Error, catchError, runError, throwError)
 import Control.Monad.Freer.Reader (ask, runReader)
 import Control.Monad.Freer.State (State, get, put, runState)
 
 
 tests :: TestTree
 tests = testGroup "Exception Eff tests"
-    [ testProperty "Exc takes precedence"
+    [ testProperty "Error takes precedence"
         $ \x y -> testExceptionTakesPriority x y == Left y
     , testCase "uncaught: runState (runError t)"
         $ ter1 @?= (Left "exc", 2)
@@ -57,7 +57,7 @@ testExceptionTakesPriority x y = run $ runError (go x y)
 -- The following won't type: unhandled exception!
 -- ex2rw = run et2
 {-
-    No instance for (Member (Exc Int) Void)
+    No instance for (Member (Error Int) Void)
       arising from a use of `et2'
 -}
 
@@ -65,7 +65,7 @@ testExceptionTakesPriority x y = run $ runError (go x y)
 incr :: Member (State Int) r => Eff r ()
 incr = get >>= put . (+ (1 :: Int))
 
-tes1 :: (Members '[State Int, Exc String] r) => Eff r b
+tes1 :: (Members '[State Int, Error String] r) => Eff r b
 tes1 = incr >> throwError "exc"
 
 ter1 :: (Either String Int, Int)
@@ -74,7 +74,7 @@ ter1 = run $ runState (runError tes1) (1 :: Int)
 ter2 :: Either String (String, Int)
 ter2 = run $ runError (runState tes1 (1 :: Int))
 
-teCatch :: Member (Exc String) r => Eff r a -> Eff r String
+teCatch :: Member (Error String) r => Eff r a -> Eff r String
 teCatch m = (m >> pure "done") `catchError` \e -> pure (e :: String)
 
 ter3 :: (Either String String, Int)
@@ -87,7 +87,7 @@ ter4 = run $ runError (runState (teCatch tes1) (1 :: Int))
 newtype TooBig = TooBig Int
   deriving (Eq, Show)
 
-ex2 :: Member (Exc TooBig) r => Eff r Int -> Eff r Int
+ex2 :: Member (Error TooBig) r => Eff r Int -> Eff r Int
 ex2 m = do
     v <- m
     if v > 5
@@ -95,7 +95,7 @@ ex2 m = do
         else pure v
 
 -- | Specialization to tell the type of the exception.
-runErrBig :: Eff (Exc TooBig ': r) a -> Eff r (Either TooBig a)
+runErrBig :: Eff (Error TooBig ': r) a -> Eff r (Either TooBig a)
 runErrBig = runError
 
 ex2rr :: Either TooBig Int