summaryrefslogtreecommitdiff
path: root/src/Control/Arrow/Free.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Control/Arrow/Free.hs')
-rw-r--r--src/Control/Arrow/Free.hs36
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)