diff options
Diffstat (limited to 'src/Control/Arrow/Free.hs')
| -rw-r--r-- | src/Control/Arrow/Free.hs | 36 |
1 files changed, 31 insertions, 5 deletions
diff --git a/src/Control/Arrow/Free.hs b/src/Control/Arrow/Free.hs index 7bae9f2..149ab13 100644 --- a/src/Control/Arrow/Free.hs +++ b/src/Control/Arrow/Free.hs @@ -32,6 +32,7 @@ module Control.Arrow.Free , eval -- * ArrowError , ArrowError(..) + , catch -- * Arrow functions , mapA , mapSeqA @@ -40,9 +41,13 @@ module Control.Arrow.Free ) where import Control.Arrow +import Control.Arrow.AppArrow import Control.Category import Control.Exception.Safe (Exception, MonadCatch) import qualified Control.Exception.Safe +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer +import qualified Control.Monad.Trans.Writer.Strict as SW import Data.Bool (Bool) import Data.Constraint (Constraint, Dict (..), mapDict, weaken1, weaken2) @@ -50,7 +55,8 @@ import Data.Either (Either (..)) import Data.Function (const, flip, ($)) import Data.List (uncons) import Data.Maybe (maybe) -import Data.Tuple (curry, uncurry) +import Data.Monoid (Monoid) +import Data.Tuple (uncurry) -- | A natural transformation on type constructors of two arguments. type x ~> y = forall a b. x a b -> y a b @@ -159,12 +165,32 @@ instance FreeArrowLike Choice where -- | ArrowError represents those arrows which can catch exceptions within the -- processing of the flow. class ArrowError ex a where - catch :: a e c -> a (e, ex) c -> a e c + try :: a e c -> a e (Either ex c) + +instance (ArrowError ex arr) => ArrowError ex (AppArrow (Reader r) arr) where + try (AppArrow act) = AppArrow $ reader $ \r -> + try $ runReader act r + +instance (ArrowError ex arr, Monoid w) => ArrowError ex (AppArrow (Writer w) arr) where + try (AppArrow act) = AppArrow $ writer (try a, w) + where (a, w) = runWriter act + +instance (ArrowError ex arr, Monoid w) => ArrowError ex (AppArrow (SW.Writer w) arr) where + try (AppArrow act) = AppArrow $ SW.writer (try a, w) + where (a, w) = SW.runWriter act + +catch :: (ArrowError ex a, ArrowChoice a) => a e c -> a (e, ex) c -> a e c +catch a onExc = proc e -> do + res <- try a -< e + case res of + Left ex -> + onExc -< (e, ex) + Right r -> + returnA -< r instance (Arrow (Kleisli m), Exception ex, MonadCatch m) => ArrowError ex (Kleisli m) where - Kleisli arr1 `catch` Kleisli arr2 = Kleisli $ \x -> - arr1 x `Control.Exception.Safe.catch` curry arr2 x + try (Kleisli a) = Kleisli $ Control.Exception.Safe.try . a -- | Freely generated arrows with both choice and error handling. newtype ErrorChoice ex eff a b = ErrorChoice { @@ -188,7 +214,7 @@ instance ArrowChoice (ErrorChoice ex eff) where (ErrorChoice a) ||| (ErrorChoice b) = ErrorChoice $ \f -> a f ||| b f instance ArrowError ex (ErrorChoice ex eff) where - (ErrorChoice a) `catch` (ErrorChoice h) = ErrorChoice $ \f -> a f `catch` h f + try (ErrorChoice a) = ErrorChoice $ \f -> try $ a f instance FreeArrowLike (ErrorChoice ex) where type Ctx (ErrorChoice ex) = Join ArrowChoice (ArrowError ex) |