{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Arrow.Transformer.Error
-- Copyright   :  (c) Ross Paterson 2003
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  R.Paterson@city.ac.uk
-- Stability   :  experimental
-- Portability :  non-portable (multi-parameter type classes)
--
-- An arrow transformer that adds error handling.
--
-- /TODO:/ the operations here are inconsistent with other arrow transformers.

module Control.Arrow.Transformer.Error(
    ErrorArrow(ErrorArrow),
    runError,
    ArrowAddError(..),
    ) where

import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer

import Control.Applicative
import Control.Arrow
import Control.Category
import Data.Monoid
#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,11,0))
import Data.Semigroup
#endif

import Prelude hiding (id,(.))

-- | An arrow that augments an existing arrow with possible errors.
-- The 'ArrowError' class contains methods for raising and handling
-- these errors.

newtype ErrorArrow ex a b c = ErrorArrow (a b (Either ex c))

rstrength :: (Either ex a, b) -> Either ex (a, b)
rstrength :: (Either ex a, b) -> Either ex (a, b)
rstrength (Left ex
ex, b
_) = ex -> Either ex (a, b)
forall a b. a -> Either a b
Left ex
ex
rstrength (Right a
a, b
b) = (a, b) -> Either ex (a, b)
forall a b. b -> Either a b
Right (a
a, b
b)

-- | Encapsulate an error-raising computation,
-- by completely handling any errors.
--
-- Typical usage in arrow notation:
--
-- >    proc p -> ...
-- >        body `runError` \ex -> handler

runError :: ArrowChoice a =>
    ErrorArrow ex a e b  -- ^ computation that may raise errors
    -> a (e,ex) b        -- ^ computation to handle errors
    -> a e b
runError :: ErrorArrow ex a e b -> a (e, ex) b -> a e b
runError (ErrorArrow a e (Either ex b)
f) a (e, ex) b
h =
    (e -> e) -> a e e
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr e -> e
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id a e e -> a e (Either ex b) -> a e (e, Either ex b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a e (Either ex b)
f a e (e, Either ex b) -> a (e, Either ex b) b -> a e b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((e, Either ex b) -> Either (e, ex) b)
-> a (e, Either ex b) (Either (e, ex) b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (e, Either ex b) -> Either (e, ex) b
forall a b b. (a, Either b b) -> Either (a, b) b
strength a (e, Either ex b) (Either (e, ex) b)
-> a (Either (e, ex) b) b -> a (e, Either ex b) b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a (e, ex) b
h a (e, ex) b -> a b b -> a (Either (e, ex) b) b
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| (b -> b) -> a b b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> b
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
      where
        strength :: (a, Either b b) -> Either (a, b) b
strength (a
x, Left b
y) = (a, b) -> Either (a, b) b
forall a b. a -> Either a b
Left (a
x, b
y)
        strength (a
_, Right b
z) = b -> Either (a, b) b
forall a b. b -> Either a b
Right b
z

-- transformer

instance ArrowChoice a => ArrowTransformer (ErrorArrow ex) a where
    lift :: a b c -> ErrorArrow ex a b c
lift a b c
f = a b (Either ex c) -> ErrorArrow ex a b c
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a b c
f a b c -> a c (Either ex c) -> a b (Either ex c)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (c -> Either ex c) -> a c (Either ex c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr c -> Either ex c
forall a b. b -> Either a b
Right)

-- liftings of standard classes

instance ArrowChoice a => Category (ErrorArrow ex a) where
    id :: ErrorArrow ex a a a
id = a a (Either ex a) -> ErrorArrow ex a a a
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow ((a -> Either ex a) -> a a (Either ex a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> Either ex a
forall a b. b -> Either a b
Right)
    ErrorArrow a b (Either ex c)
f . :: ErrorArrow ex a b c -> ErrorArrow ex a a b -> ErrorArrow ex a a c
. ErrorArrow a a (Either ex b)
g =
        a a (Either ex c) -> ErrorArrow ex a a c
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow ((Either ex (Either ex c) -> Either ex c)
-> a (Either ex (Either ex c)) (Either ex c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((ex -> Either ex c)
-> (Either ex c -> Either ex c)
-> Either ex (Either ex c)
-> Either ex c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ex -> Either ex c
forall a b. a -> Either a b
Left Either ex c -> Either ex c
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id) a (Either ex (Either ex c)) (Either ex c)
-> a a (Either ex (Either ex c)) -> a a (Either ex c)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a b (Either ex c) -> a (Either ex b) (Either ex (Either ex c))
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right a b (Either ex c)
f a (Either ex b) (Either ex (Either ex c))
-> a a (Either ex b) -> a a (Either ex (Either ex c))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a a (Either ex b)
g)

instance ArrowChoice a => Arrow (ErrorArrow ex a) where
    arr :: (b -> c) -> ErrorArrow ex a b c
arr b -> c
f = a b (Either ex c) -> ErrorArrow ex a b c
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow ((b -> Either ex c) -> a b (Either ex c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (c -> Either ex c
forall a b. b -> Either a b
Right (c -> Either ex c) -> (b -> c) -> b -> Either ex c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> c
f))
    first :: ErrorArrow ex a b c -> ErrorArrow ex a (b, d) (c, d)
first (ErrorArrow a b (Either ex c)
f) = a (b, d) (Either ex (c, d)) -> ErrorArrow ex a (b, d) (c, d)
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a b (Either ex c) -> a (b, d) (Either ex c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a b (Either ex c)
f a (b, d) (Either ex c, d)
-> a (Either ex c, d) (Either ex (c, d))
-> a (b, d) (Either ex (c, d))
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Either ex c, d) -> Either ex (c, d))
-> a (Either ex c, d) (Either ex (c, d))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Either ex c, d) -> Either ex (c, d)
forall ex a b. (Either ex a, b) -> Either ex (a, b)
rstrength)

instance ArrowChoice a => ArrowChoice (ErrorArrow ex a) where
    left :: ErrorArrow ex a b c -> ErrorArrow ex a (Either b d) (Either c d)
left (ErrorArrow a b (Either ex c)
f) = a (Either b d) (Either ex (Either c d))
-> ErrorArrow ex a (Either b d) (Either c d)
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a b (Either ex c) -> a (Either b d) (Either (Either ex c) d)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left a b (Either ex c)
f a (Either b d) (Either (Either ex c) d)
-> a (Either (Either ex c) d) (Either ex (Either c d))
-> a (Either b d) (Either ex (Either c d))
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Either (Either ex c) d -> Either ex (Either c d))
-> a (Either (Either ex c) d) (Either ex (Either c d))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Either (Either ex c) d -> Either ex (Either c d)
forall a b c. Either (Either a b) c -> Either a (Either b c)
assocsum)

assocsum :: Either (Either a b) c -> Either a (Either b c)
assocsum :: Either (Either a b) c -> Either a (Either b c)
assocsum (Left (Left a
a)) = a -> Either a (Either b c)
forall a b. a -> Either a b
Left a
a
assocsum (Left (Right b
b)) = Either b c -> Either a (Either b c)
forall a b. b -> Either a b
Right (b -> Either b c
forall a b. a -> Either a b
Left b
b)
assocsum (Right c
c) = Either b c -> Either a (Either b c)
forall a b. b -> Either a b
Right (c -> Either b c
forall a b. b -> Either a b
Right c
c)

instance (ArrowChoice a, ArrowApply a) => ArrowApply (ErrorArrow ex a) where
    app :: ErrorArrow ex a (ErrorArrow ex a b c, b) c
app = a (ErrorArrow ex a b c, b) (Either ex c)
-> ErrorArrow ex a (ErrorArrow ex a b c, b) c
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (((ErrorArrow ex a b c, b) -> (a b (Either ex c), b))
-> a (ErrorArrow ex a b c, b) (a b (Either ex c), b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(ErrorArrow a b (Either ex c)
f, b
x) -> (a b (Either ex c)
f, b
x)) a (ErrorArrow ex a b c, b) (a b (Either ex c), b)
-> a (a b (Either ex c), b) (Either ex c)
-> a (ErrorArrow ex a b c, b) (Either ex c)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a (a b (Either ex c), b) (Either ex c)
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app)

-- this instance has the right type, but it doesn't satisfy right
-- tightening, or sliding of non-strict functions.

instance (ArrowChoice a, ArrowLoop a) => ArrowLoop (ErrorArrow ex a) where
    loop :: ErrorArrow ex a (b, d) (c, d) -> ErrorArrow ex a b c
loop (ErrorArrow a (b, d) (Either ex (c, d))
f) = a b (Either ex c) -> ErrorArrow ex a b c
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a (b, d) (Either ex c, d) -> a b (Either ex c)
forall (a :: * -> * -> *) b d c.
ArrowLoop a =>
a (b, d) (c, d) -> a b c
loop (a (b, d) (Either ex (c, d))
f a (b, d) (Either ex (c, d))
-> a (Either ex (c, d)) (Either ex c, d)
-> a (b, d) (Either ex c, d)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Either ex (c, d) -> (Either ex c, d))
-> a (Either ex (c, d)) (Either ex c, d)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Either ex (c, d) -> (Either ex c, d)
forall a a b. Either a (a, b) -> (Either a a, b)
dist))
      where
        dist :: Either a (a, b) -> (Either a a, b)
dist Either a (a, b)
x = (Either a (a, b) -> Either a a
forall a b b. Either a (b, b) -> Either a b
fstRight Either a (a, b)
x, (a, b) -> b
forall a b. (a, b) -> b
snd ((a, b) -> b) -> (a, b) -> b
forall a b. (a -> b) -> a -> b
$ Either a (a, b) -> (a, b)
forall a p. Either a p -> p
fromRight Either a (a, b)
x)
        fstRight :: Either a (b, b) -> Either a b
fstRight (Left a
x) = a -> Either a b
forall a b. a -> Either a b
Left a
x
        fstRight (Right (b
x,b
_)) = b -> Either a b
forall a b. b -> Either a b
Right b
x
        fromRight :: Either a p -> p
fromRight (Left a
_) = [Char] -> p
forall a. HasCallStack => [Char] -> a
error [Char]
"fromRight"
        fromRight (Right p
y) = p
y

-- Other instances

instance ArrowChoice a => Functor (ErrorArrow ex a b) where
    fmap :: (a -> b) -> ErrorArrow ex a b a -> ErrorArrow ex a b b
fmap a -> b
f ErrorArrow ex a b a
g = ErrorArrow ex a b a
g ErrorArrow ex a b a -> ErrorArrow ex a a b -> ErrorArrow ex a b b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (a -> b) -> ErrorArrow ex a a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f

instance ArrowChoice a => Applicative (ErrorArrow ex a b) where
    pure :: a -> ErrorArrow ex a b a
pure a
x = (b -> a) -> ErrorArrow ex a b a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (a -> b -> a
forall a b. a -> b -> a
const a
x)
    ErrorArrow ex a b (a -> b)
f <*> :: ErrorArrow ex a b (a -> b)
-> ErrorArrow ex a b a -> ErrorArrow ex a b b
<*> ErrorArrow ex a b a
g = ErrorArrow ex a b (a -> b)
f ErrorArrow ex a b (a -> b)
-> ErrorArrow ex a b a -> ErrorArrow ex a b (a -> b, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ErrorArrow ex a b a
g ErrorArrow ex a b (a -> b, a)
-> ErrorArrow ex a (a -> b, a) b -> ErrorArrow ex a b b
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((a -> b, a) -> b) -> ErrorArrow ex a (a -> b, a) b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (((a -> b) -> a -> b) -> (a -> b, a) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (a -> b) -> a -> b
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)

instance (Monoid ex, ArrowChoice a) => Alternative (ErrorArrow ex a b) where
    empty :: ErrorArrow ex a b a
empty = ErrorArrow ex a b a
forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
    ErrorArrow ex a b a
f <|> :: ErrorArrow ex a b a -> ErrorArrow ex a b a -> ErrorArrow ex a b a
<|> ErrorArrow ex a b a
g = ErrorArrow ex a b a
f ErrorArrow ex a b a -> ErrorArrow ex a b a -> ErrorArrow ex a b a
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> ErrorArrow ex a b a
g

#if MIN_VERSION_base(4,9,0)
instance (Monoid ex, ArrowChoice a) => Semigroup (ErrorArrow ex a b c) where
    <> :: ErrorArrow ex a b c -> ErrorArrow ex a b c -> ErrorArrow ex a b c
(<>) = ErrorArrow ex a b c -> ErrorArrow ex a b c -> ErrorArrow ex a b c
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
(<+>)
#endif

instance (Monoid ex, ArrowChoice a) => Monoid (ErrorArrow ex a b c) where
    mempty :: ErrorArrow ex a b c
mempty = ErrorArrow ex a b c
forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
#if !(MIN_VERSION_base(4,11,0))
    mappend = (<+>)
#endif

-- fresh instances

instance ArrowChoice a => ArrowError ex (ErrorArrow ex a) where
    raise :: ErrorArrow ex a ex b
raise = a ex (Either ex b) -> ErrorArrow ex a ex b
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow ((ex -> Either ex b) -> a ex (Either ex b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ex -> Either ex b
forall a b. a -> Either a b
Left)
    handle :: ErrorArrow ex a e b
-> ErrorArrow ex a (e, ex) b -> ErrorArrow ex a e b
handle (ErrorArrow a e (Either ex b)
f) (ErrorArrow a (e, ex) (Either ex b)
h) =
        a e (Either ex b) -> ErrorArrow ex a e b
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow ((e -> e) -> a e e
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr e -> e
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id a e e -> a e (Either ex b) -> a e (e, Either ex b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a e (Either ex b)
f a e (e, Either ex b)
-> a (e, Either ex b) (Either ex b) -> a e (Either ex b)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((e, Either ex b) -> Either (e, ex) b)
-> a (e, Either ex b) (Either (e, ex) b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (e, Either ex b) -> Either (e, ex) b
forall a b b. (a, Either b b) -> Either (a, b) b
strength a (e, Either ex b) (Either (e, ex) b)
-> a (Either (e, ex) b) (Either ex b)
-> a (e, Either ex b) (Either ex b)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a (e, ex) (Either ex b)
h a (e, ex) (Either ex b)
-> a b (Either ex b) -> a (Either (e, ex) b) (Either ex b)
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| (b -> Either ex b) -> a b (Either ex b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> Either ex b
forall a b. b -> Either a b
Right)
      where
        strength :: (a, Either b b) -> Either (a, b) b
strength (a
x, Left b
y) = (a, b) -> Either (a, b) b
forall a b. a -> Either a b
Left (a
x, b
y)
        strength (a
_, Right b
z) = b -> Either (a, b) b
forall a b. b -> Either a b
Right b
z
    tryInUnless :: ErrorArrow ex a e b
-> ErrorArrow ex a (e, b) c
-> ErrorArrow ex a (e, ex) c
-> ErrorArrow ex a e c
tryInUnless (ErrorArrow a e (Either ex b)
f) (ErrorArrow a (e, b) (Either ex c)
s) (ErrorArrow a (e, ex) (Either ex c)
h) =
        a e (Either ex c) -> ErrorArrow ex a e c
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow ((e -> e) -> a e e
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr e -> e
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id a e e -> a e (Either ex b) -> a e (e, Either ex b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& a e (Either ex b)
f a e (e, Either ex b)
-> a (e, Either ex b) (Either ex c) -> a e (Either ex c)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((e, Either ex b) -> Either (e, ex) (e, b))
-> a (e, Either ex b) (Either (e, ex) (e, b))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (e, Either ex b) -> Either (e, ex) (e, b)
forall a b b. (a, Either b b) -> Either (a, b) (a, b)
distr a (e, Either ex b) (Either (e, ex) (e, b))
-> a (Either (e, ex) (e, b)) (Either ex c)
-> a (e, Either ex b) (Either ex c)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a (e, ex) (Either ex c)
h a (e, ex) (Either ex c)
-> a (e, b) (Either ex c)
-> a (Either (e, ex) (e, b)) (Either ex c)
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| a (e, b) (Either ex c)
s)
      where
        distr :: (a, Either b b) -> Either (a, b) (a, b)
distr (a
b, Left b
ex) = (a, b) -> Either (a, b) (a, b)
forall a b. a -> Either a b
Left (a
b, b
ex)
        distr (a
b, Right b
c) = (a, b) -> Either (a, b) (a, b)
forall a b. b -> Either a b
Right (a
b, b
c)

instance ArrowChoice a => ArrowAddError ex (ErrorArrow ex a) a where
    liftError :: a e b -> ErrorArrow ex a e b
liftError = a e b -> ErrorArrow ex a e b
forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift
    elimError :: ErrorArrow ex a e b -> a (e, ex) b -> a e b
elimError = ErrorArrow ex a e b -> a (e, ex) b -> a e b
forall (a :: * -> * -> *) ex e b.
ArrowChoice a =>
ErrorArrow ex a e b -> a (e, ex) b -> a e b
runError

instance (Monoid ex, ArrowChoice a) => ArrowZero (ErrorArrow ex a) where
    zeroArrow :: ErrorArrow ex a b c
zeroArrow = a b (Either ex c) -> ErrorArrow ex a b c
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow ((b -> Either ex c) -> a b (Either ex c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Either ex c -> b -> Either ex c
forall a b. a -> b -> a
const (ex -> Either ex c
forall a b. a -> Either a b
Left ex
forall a. Monoid a => a
mempty)))

instance (Monoid ex, ArrowChoice a) => ArrowPlus (ErrorArrow ex a) where
    ErrorArrow ex a b c
f <+> :: ErrorArrow ex a b c -> ErrorArrow ex a b c -> ErrorArrow ex a b c
<+> ErrorArrow ex a b c
g = ErrorArrow ex a b c
-> ErrorArrow ex a (b, ex) c -> ErrorArrow ex a b c
forall ex (a :: * -> * -> *) e b.
ArrowError ex a =>
a e b -> a (e, ex) b -> a e b
handle ErrorArrow ex a b c
f (ErrorArrow ex a (b, ex) c -> ErrorArrow ex a b c)
-> ErrorArrow ex a (b, ex) c -> ErrorArrow ex a b c
forall a b. (a -> b) -> a -> b
$ ErrorArrow ex a (b, ex) c
-> ErrorArrow ex a ((b, ex), ex) c -> ErrorArrow ex a (b, ex) c
forall ex (a :: * -> * -> *) e b.
ArrowError ex a =>
a e b -> a (e, ex) b -> a e b
handle (((b, ex) -> b) -> ErrorArrow ex a (b, ex) b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (b, ex) -> b
forall a b. (a, b) -> a
fst ErrorArrow ex a (b, ex) b
-> ErrorArrow ex a b c -> ErrorArrow ex a (b, ex) c
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ErrorArrow ex a b c
g) (ErrorArrow ex a ((b, ex), ex) c -> ErrorArrow ex a (b, ex) c)
-> ErrorArrow ex a ((b, ex), ex) c -> ErrorArrow ex a (b, ex) c
forall a b. (a -> b) -> a -> b
$
        a ((b, ex), ex) (Either ex c) -> ErrorArrow ex a ((b, ex), ex) c
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow ((((b, ex), ex) -> Either ex c) -> a ((b, ex), ex) (Either ex c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\((b
_,ex
ex1), ex
ex2) -> ex -> Either ex c
forall a b. a -> Either a b
Left (ex
ex1 ex -> ex -> ex
forall a. Monoid a => a -> a -> a
`mappend` ex
ex2)))

-- liftings of other arrow classes

-- specializations of general promotions

instance (ArrowReader r a, ArrowChoice a) =>
        ArrowReader r (ErrorArrow ex a) where
    readState :: ErrorArrow ex a b r
readState = a b r -> ErrorArrow ex a b r
forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift a b r
forall r (a :: * -> * -> *) b. ArrowReader r a => a b r
readState
    newReader :: ErrorArrow ex a e b -> ErrorArrow ex a (e, r) b
newReader (ErrorArrow a e (Either ex b)
f) = a (e, r) (Either ex b) -> ErrorArrow ex a (e, r) b
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a e (Either ex b) -> a (e, r) (Either ex b)
forall r (a :: * -> * -> *) e b.
ArrowReader r a =>
a e b -> a (e, r) b
newReader a e (Either ex b)
f)

instance (ArrowState s a, ArrowChoice a) =>
        ArrowState s (ErrorArrow ex a) where
    fetch :: ErrorArrow ex a e s
fetch = a e s -> ErrorArrow ex a e s
forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift a e s
forall s (a :: * -> * -> *) e. ArrowState s a => a e s
fetch
    store :: ErrorArrow ex a s ()
store = a s () -> ErrorArrow ex a s ()
forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift a s ()
forall s (a :: * -> * -> *). ArrowState s a => a s ()
store

instance (ArrowWriter w a, ArrowChoice a) =>
        ArrowWriter w (ErrorArrow ex a) where
    write :: ErrorArrow ex a w ()
write = a w () -> ErrorArrow ex a w ()
forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift a w ()
forall w (a :: * -> * -> *). ArrowWriter w a => a w ()
write
    newWriter :: ErrorArrow ex a e b -> ErrorArrow ex a e (b, w)
newWriter (ErrorArrow a e (Either ex b)
f) = a e (Either ex (b, w)) -> ErrorArrow ex a e (b, w)
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a e (Either ex b) -> a e (Either ex b, w)
forall w (a :: * -> * -> *) e b.
ArrowWriter w a =>
a e b -> a e (b, w)
newWriter a e (Either ex b)
f a e (Either ex b, w)
-> a (Either ex b, w) (Either ex (b, w)) -> a e (Either ex (b, w))
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Either ex b, w) -> Either ex (b, w))
-> a (Either ex b, w) (Either ex (b, w))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Either ex b, w) -> Either ex (b, w)
forall ex a b. (Either ex a, b) -> Either ex (a, b)
rstrength)

-- promotions

instance (ArrowAddReader r a a', ArrowChoice a, ArrowChoice a') =>
        ArrowAddReader r (ErrorArrow ex a) (ErrorArrow ex a') where
    liftReader :: ErrorArrow ex a' e b -> ErrorArrow ex a e b
liftReader (ErrorArrow a' e (Either ex b)
f) = a e (Either ex b) -> ErrorArrow ex a e b
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a' e (Either ex b) -> a e (Either ex b)
forall r (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddReader r a a' =>
a' e b -> a e b
liftReader a' e (Either ex b)
f)
    elimReader :: ErrorArrow ex a e b -> ErrorArrow ex a' (e, r) b
elimReader (ErrorArrow a e (Either ex b)
f) = a' (e, r) (Either ex b) -> ErrorArrow ex a' (e, r) b
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a e (Either ex b) -> a' (e, r) (Either ex b)
forall r (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddReader r a a' =>
a e b -> a' (e, r) b
elimReader a e (Either ex b)
f)

instance (ArrowAddState s a a', ArrowChoice a, ArrowChoice a') =>
        ArrowAddState s (ErrorArrow ex a) (ErrorArrow ex a') where
    liftState :: ErrorArrow ex a' e b -> ErrorArrow ex a e b
liftState (ErrorArrow a' e (Either ex b)
f) = a e (Either ex b) -> ErrorArrow ex a e b
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a' e (Either ex b) -> a e (Either ex b)
forall s (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddState s a a' =>
a' e b -> a e b
liftState a' e (Either ex b)
f)
    elimState :: ErrorArrow ex a e b -> ErrorArrow ex a' (e, s) (b, s)
elimState (ErrorArrow a e (Either ex b)
f) = a' (e, s) (Either ex (b, s)) -> ErrorArrow ex a' (e, s) (b, s)
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a e (Either ex b) -> a' (e, s) (Either ex b, s)
forall s (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddState s a a' =>
a e b -> a' (e, s) (b, s)
elimState a e (Either ex b)
f a' (e, s) (Either ex b, s)
-> a' (Either ex b, s) (Either ex (b, s))
-> a' (e, s) (Either ex (b, s))
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Either ex b, s) -> Either ex (b, s))
-> a' (Either ex b, s) (Either ex (b, s))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Either ex b, s) -> Either ex (b, s)
forall ex a b. (Either ex a, b) -> Either ex (a, b)
rstrength)

instance (ArrowAddWriter w a a', ArrowChoice a, ArrowChoice a') =>
        ArrowAddWriter w (ErrorArrow ex a) (ErrorArrow ex a') where
    liftWriter :: ErrorArrow ex a' e b -> ErrorArrow ex a e b
liftWriter (ErrorArrow a' e (Either ex b)
f) = a e (Either ex b) -> ErrorArrow ex a e b
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a' e (Either ex b) -> a e (Either ex b)
forall w (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddWriter w a a' =>
a' e b -> a e b
liftWriter a' e (Either ex b)
f)
    elimWriter :: ErrorArrow ex a e b -> ErrorArrow ex a' e (b, w)
elimWriter (ErrorArrow a e (Either ex b)
f) = a' e (Either ex (b, w)) -> ErrorArrow ex a' e (b, w)
forall ex (a :: * -> * -> *) b c.
a b (Either ex c) -> ErrorArrow ex a b c
ErrorArrow (a e (Either ex b) -> a' e (Either ex b, w)
forall w (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddWriter w a a' =>
a e b -> a' e (b, w)
elimWriter a e (Either ex b)
f a' e (Either ex b, w)
-> a' (Either ex b, w) (Either ex (b, w))
-> a' e (Either ex (b, w))
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Either ex b, w) -> Either ex (b, w))
-> a' (Either ex b, w) (Either ex (b, w))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Either ex b, w) -> Either ex (b, w)
forall ex a b. (Either ex a, b) -> Either ex (a, b)
rstrength)