Rename Exception to Error and add some more effect handlers

This commit is contained in:
Alexis King 2017-12-05 14:40:48 -08:00
parent 83a37ee3a8
commit 594f4518b6
9 changed files with 95 additions and 43 deletions

View File

@ -35,7 +35,7 @@ import Criterion.Main (defaultMain)
import Control.Monad.Freer (Member, Eff, run, send) import Control.Monad.Freer (Member, Eff, run, send)
import Control.Monad.Freer.Internal (Eff(E, Val), decomp, qApp, tsingleton) 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.State (get, put, runState)
import Control.Monad.Freer.StateRW (ask, tell, runStateR) import Control.Monad.Freer.StateRW (ask, tell, runStateR)

View File

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

View File

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

View File

@ -6,7 +6,7 @@ module Cut () where
{- {-
-- The signature is inferred -- 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'` tcut1 = (return (1::Int) `mplus'` return 2) `mplus'`
((cutfalse `mplus'` return 4) `mplus'` ((cutfalse `mplus'` return 4) `mplus'`
return 5) return 5)

View File

@ -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 -- see: https://github.com/sol/hpack
@ -68,7 +68,7 @@ library
Control.Monad.Freer Control.Monad.Freer
Control.Monad.Freer.Coroutine Control.Monad.Freer.Coroutine
Control.Monad.Freer.Cut Control.Monad.Freer.Cut
Control.Monad.Freer.Exception Control.Monad.Freer.Error
Control.Monad.Freer.Fresh Control.Monad.Freer.Fresh
Control.Monad.Freer.Internal Control.Monad.Freer.Internal
Control.Monad.Freer.NonDet Control.Monad.Freer.NonDet
@ -80,6 +80,8 @@ library
Data.FTCQueue Data.FTCQueue
Data.OpenUnion Data.OpenUnion
Data.OpenUnion.Internal Data.OpenUnion.Internal
other-modules:
Paths_freer_effects
default-language: Haskell2010 default-language: Haskell2010
executable freer-examples executable freer-examples

View File

@ -22,7 +22,7 @@ module Control.Monad.Freer
, Members , Members
, LastMember , LastMember
-- ** Sending Arbitrary Effect -- ** Sending Arbitrary Effects
, send , send
, sendM , sendM
@ -30,28 +30,35 @@ module Control.Monad.Freer
, raise , raise
-- * Handling Effects -- * Handling Effects
, Arr
, run , run
, runM , runM
-- ** Building Effect Handlers -- ** Building Effect Handlers
-- *** Basic effect handlers
, interpret , interpret
, interpose
-- *** Derived effect handlers
, reinterpret , reinterpret
, reinterpret2 , reinterpret2
, reinterpret3 , reinterpret3
, reinterpretN , reinterpretN
, translate , translate
-- *** Monadic effect handlers
, interpretM , interpretM
-- *** Advanced effect handlers
, interpretWith
, interposeWith
) where ) where
import qualified Control.Monad.Freer.Internal as Internal
import Control.Applicative (pure) import Control.Applicative (pure)
import Control.Monad (Monad, (>>=)) import Control.Monad (Monad, (>>=))
import Control.Natural (type (~>)) import Control.Natural (type (~>))
import Data.Function ((.)) import Data.Function ((.))
import Control.Monad.Freer.Internal import Control.Monad.Freer.Internal
( Arr ( Eff
, Eff
, LastMember , LastMember
, Member , Member
, Members , Members
@ -72,7 +79,12 @@ import Control.Monad.Freer.Internal
-- effects @effs@, produces a natural transformation from @'Eff' (eff ': effs)@ -- effects @effs@, produces a natural transformation from @'Eff' (eff ': effs)@
-- to @'Eff' effs@. -- to @'Eff' effs@.
interpret :: (eff ~> Eff effs) -> Eff (eff ': effs) ~> 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@, -- | Like 'interpret', but instead of removing the interpreted effect @f@,
-- reencodes it in some new effect @g@. -- 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 ~> g) -> Eff (f ': effs) ~> Eff (g ': effs)
translate f = reinterpret (send . f) 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 -- one. Like 'translate', this function runs an effect by translating it into
-- another effect in isolation, without access to the other effects in @effs@. -- 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 -- Unlike either of those functions, however, this runs the effect in a final
@ -133,3 +145,33 @@ interpretM
:: (Monad m, LastMember m effs) :: (Monad m, LastMember m effs)
=> (eff ~> m) -> Eff (eff ': effs) ~> Eff effs => (eff ~> m) -> Eff (eff ': effs) ~> Eff effs
interpretM f = interpret (sendM . f) 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

View File

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

View File

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

View File

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