{-# LANGUAGE Arrows #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Control.Arrow.Trans
  ( ArrowTrans (..),
    ArrowError (..),
    liftEitherA,
    mapErrorA,
    ErrorA (..),
    ArrowReader (..),
    ReaderA (..),
    ArrowWriter (..),
    WriterA (WriterA, runWriterA),
  )
where

import Control.Arrow
import Control.Category
import Control.Monad.Error.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Prelude hiding (id, (.))

class (Arrow arr, Arrow (t arr)) => ArrowTrans t arr where
  liftA :: arr a b -> t arr a b

class (Arrow arr) => ArrowError e arr | arr -> e where
  throwA :: arr e a

  -- see Note [Weird control operator types]
  catchA :: arr (a, s) b -> arr (a, (e, s)) b -> arr (a, s) b

liftEitherA :: (ArrowChoice arr, ArrowError e arr) => arr (Either e a) a
liftEitherA :: arr (Either e a) a
liftEitherA = arr e a
forall e (arr :: * -> * -> *) a. ArrowError e arr => arr e a
throwA arr e a -> arr a a -> arr (Either e a) a
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| arr a a
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA
{-# INLINE liftEitherA #-}

mapErrorA :: (ArrowError e arr) => arr (a, s) b -> arr (a, (e -> e, s)) b
mapErrorA :: arr (a, s) b -> arr (a, (e -> e, s)) b
mapErrorA arr (a, s) b
f = proc (a
a, (e -> e
g, s
s)) -> (arr (a, s) b
f -< (a
a, s
s)) forall a. arr (a, ()) b -> arr (a, (e, ())) b -> arr (a, ()) b
forall e (arr :: * -> * -> *) a s b.
ArrowError e arr =>
arr (a, s) b -> arr (a, (e, s)) b -> arr (a, s) b
`catchA` \e
e -> arr e b
forall e (arr :: * -> * -> *) a. ArrowError e arr => arr e a
throwA -< e -> e
g e
e
{-# INLINE mapErrorA #-}

class (Arrow arr) => ArrowReader r arr | arr -> r where
  askA :: arr a r

  -- see Note [Weird control operator types]
  localA :: arr (a, s) b -> arr (a, (r, s)) b

class (Monoid w, Arrow arr) => ArrowWriter w arr | arr -> w where
  tellA :: arr w ()
  listenA :: arr a b -> arr a (b, w)

instance (MonadError e m) => ArrowError e (Kleisli m) where
  throwA :: Kleisli m e a
throwA = (e -> m a) -> Kleisli m e a
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchA :: Kleisli m (a, s) b -> Kleisli m (a, (e, s)) b -> Kleisli m (a, s) b
catchA (Kleisli (a, s) -> m b
f) (Kleisli (a, (e, s)) -> m b
g) = ((a, s) -> m b) -> Kleisli m (a, s) b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli \(a
a, s
s) -> (a, s) -> m b
f (a
a, s
s) m b -> (e -> m b) -> m b
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \e
e -> (a, (e, s)) -> m b
g (a
a, (e
e, s
s))

instance (MonadReader r m) => ArrowReader r (Kleisli m) where
  askA :: Kleisli m a r
askA = (a -> m r) -> Kleisli m a r
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((a -> m r) -> Kleisli m a r) -> (a -> m r) -> Kleisli m a r
forall a b. (a -> b) -> a -> b
$ m r -> a -> m r
forall a b. a -> b -> a
const m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  localA :: Kleisli m (a, s) b -> Kleisli m (a, (r, s)) b
localA (Kleisli (a, s) -> m b
f) = ((a, (r, s)) -> m b) -> Kleisli m (a, (r, s)) b
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli \(a
a, (r
r, s
s)) -> (r -> r) -> m b -> m b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (r -> r -> r
forall a b. a -> b -> a
const r
r) ((a, s) -> m b
f (a
a, s
s))

instance (MonadWriter w m) => ArrowWriter w (Kleisli m) where
  tellA :: Kleisli m w ()
tellA = (w -> m ()) -> Kleisli m w ()
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell
  listenA :: Kleisli m a b -> Kleisli m a (b, w)
listenA (Kleisli a -> m b
f) = (a -> m (b, w)) -> Kleisli m a (b, w)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli (m b -> m (b, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (m b -> m (b, w)) -> (a -> m b) -> a -> m (b, w)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m b
f)

newtype ErrorA e arr a b = ErrorA {ErrorA e arr a b -> arr a (Either e b)
runErrorA :: arr a (Either e b)}
  deriving (a -> ErrorA e arr a b -> ErrorA e arr a a
(a -> b) -> ErrorA e arr a a -> ErrorA e arr a b
(forall a b. (a -> b) -> ErrorA e arr a a -> ErrorA e arr a b)
-> (forall a b. a -> ErrorA e arr a b -> ErrorA e arr a a)
-> Functor (ErrorA e arr a)
forall a b. a -> ErrorA e arr a b -> ErrorA e arr a a
forall a b. (a -> b) -> ErrorA e arr a a -> ErrorA e arr a b
forall e (arr :: * -> * -> *) a a b.
Functor (arr a) =>
a -> ErrorA e arr a b -> ErrorA e arr a a
forall e (arr :: * -> * -> *) a a b.
Functor (arr a) =>
(a -> b) -> ErrorA e arr a a -> ErrorA e arr a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ErrorA e arr a b -> ErrorA e arr a a
$c<$ :: forall e (arr :: * -> * -> *) a a b.
Functor (arr a) =>
a -> ErrorA e arr a b -> ErrorA e arr a a
fmap :: (a -> b) -> ErrorA e arr a a -> ErrorA e arr a b
$cfmap :: forall e (arr :: * -> * -> *) a a b.
Functor (arr a) =>
(a -> b) -> ErrorA e arr a a -> ErrorA e arr a b
Functor)

instance (ArrowChoice arr) => Category (ErrorA e arr) where
  id :: ErrorA e arr a a
id = arr a (Either e a) -> ErrorA e arr a a
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA ((a -> Either e a) -> arr a (Either e a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> Either e a
forall a b. b -> Either a b
Right)
  {-# INLINE id #-}
  ErrorA arr b (Either e c)
f . :: ErrorA e arr b c -> ErrorA e arr a b -> ErrorA e arr a c
. ErrorA arr a (Either e b)
g = arr a (Either e c) -> ErrorA e arr a c
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA (((e -> Either e c) -> arr e (Either e c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr e -> Either e c
forall a b. a -> Either a b
Left arr e (Either e c)
-> arr b (Either e c) -> arr (Either e b) (Either e c)
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| arr b (Either e c)
f) arr (Either e b) (Either e c)
-> arr a (Either e b) -> arr a (Either e c)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr a (Either e b)
g)
  {-# INLINEABLE (.) #-}

sequenceFirst :: (Functor f) => (f a, b) -> f (a, b)
sequenceFirst :: (f a, b) -> f (a, b)
sequenceFirst (f a
a, b
b) = (,b
b) (a -> (a, b)) -> f a -> f (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
a
{-# INLINEABLE sequenceFirst #-}

instance (ArrowChoice arr) => Arrow (ErrorA e arr) where
  arr :: (b -> c) -> ErrorA e arr b c
arr b -> c
f = arr b (Either e c) -> ErrorA e arr b c
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA ((b -> Either e c) -> arr b (Either e c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (c -> Either e c
forall a b. b -> Either a b
Right (c -> Either e c) -> (b -> c) -> b -> Either e 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))
  {-# INLINE arr #-}
  first :: ErrorA e arr b c -> ErrorA e arr (b, d) (c, d)
first (ErrorA arr b (Either e c)
f) = arr (b, d) (Either e (c, d)) -> ErrorA e arr (b, d) (c, d)
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA (((Either e c, d) -> Either e (c, d))
-> arr (Either e c, d) (Either e (c, d))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Either e c, d) -> Either e (c, d)
forall (f :: * -> *) a b. Functor f => (f a, b) -> f (a, b)
sequenceFirst arr (Either e c, d) (Either e (c, d))
-> arr (b, d) (Either e c, d) -> arr (b, d) (Either e (c, d))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr b (Either e c) -> arr (b, d) (Either e c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first arr b (Either e c)
f)
  {-# INLINE first #-}

reassociateEither :: Either (Either a b) c -> Either a (Either b c)
reassociateEither :: Either (Either a b) c -> Either a (Either b c)
reassociateEither = (Either a b -> Either a (Either b c))
-> (c -> Either a (Either b c))
-> Either (Either a b) c
-> Either a (Either b c)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((a -> Either a (Either b c))
-> (b -> Either a (Either b c))
-> Either a b
-> Either a (Either b c)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Either a (Either b c)
forall a b. a -> Either a b
Left (Either b c -> Either a (Either b c)
forall a b. b -> Either a b
Right (Either b c -> Either a (Either b c))
-> (b -> Either b c) -> b -> Either a (Either b c)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> Either b c
forall a b. a -> Either a b
Left)) (Either b c -> Either a (Either b c)
forall a b. b -> Either a b
Right (Either b c -> Either a (Either b c))
-> (c -> Either b c) -> c -> Either a (Either b c)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. c -> Either b c
forall a b. b -> Either a b
Right)

instance (ArrowChoice arr) => ArrowChoice (ErrorA e arr) where
  left :: ErrorA e arr b c -> ErrorA e arr (Either b d) (Either c d)
left (ErrorA arr b (Either e c)
f) = arr (Either b d) (Either e (Either c d))
-> ErrorA e arr (Either b d) (Either c d)
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA ((Either (Either e c) d -> Either e (Either c d))
-> arr (Either (Either e c) d) (Either e (Either c d))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Either (Either e c) d -> Either e (Either c d)
forall a b c. Either (Either a b) c -> Either a (Either b c)
reassociateEither arr (Either (Either e c) d) (Either e (Either c d))
-> arr (Either b d) (Either (Either e c) d)
-> arr (Either b d) (Either e (Either c d))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr b (Either e c) -> arr (Either b d) (Either (Either e c) d)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left arr b (Either e c)
f)
  {-# INLINE left #-}
  ErrorA arr b (Either e d)
f ||| :: ErrorA e arr b d -> ErrorA e arr c d -> ErrorA e arr (Either b c) d
||| ErrorA arr c (Either e d)
g = arr (Either b c) (Either e d) -> ErrorA e arr (Either b c) d
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA (arr b (Either e d)
f arr b (Either e d)
-> arr c (Either e d) -> arr (Either b c) (Either e d)
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| arr c (Either e d)
g)
  {-# INLINE (|||) #-}

instance (ArrowChoice arr, ArrowApply arr) => ArrowApply (ErrorA e arr) where
  app :: ErrorA e arr (ErrorA e arr b c, b) c
app = arr (ErrorA e arr b c, b) (Either e c)
-> ErrorA e arr (ErrorA e arr b c, b) c
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA (arr (arr b (Either e c), b) (Either e c)
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app arr (arr b (Either e c), b) (Either e c)
-> arr (ErrorA e arr b c, b) (arr b (Either e c), b)
-> arr (ErrorA e arr b c, b) (Either e c)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr (ErrorA e arr b c) (arr b (Either e c))
-> arr (ErrorA e arr b c, b) (arr b (Either e c), b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((ErrorA e arr b c -> arr b (Either e c))
-> arr (ErrorA e arr b c) (arr b (Either e c))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ErrorA e arr b c -> arr b (Either e c)
forall e (arr :: * -> * -> *) a b.
ErrorA e arr a b -> arr a (Either e b)
runErrorA))
  {-# INLINE app #-}

instance (ArrowChoice arr) => ArrowTrans (ErrorA e) arr where
  liftA :: arr a b -> ErrorA e arr a b
liftA arr a b
f = arr a (Either e b) -> ErrorA e arr a b
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA ((b -> Either e b) -> arr b (Either e b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> Either e b
forall a b. b -> Either a b
Right arr b (Either e b) -> arr a b -> arr a (Either e b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr a b
f)
  {-# INLINE liftA #-}

instance (ArrowChoice arr) => ArrowError e (ErrorA e arr) where
  throwA :: ErrorA e arr e a
throwA = arr e (Either e a) -> ErrorA e arr e a
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA ((e -> Either e a) -> arr e (Either e a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr e -> Either e a
forall a b. a -> Either a b
Left)
  {-# INLINE throwA #-}
  catchA :: ErrorA e arr (a, s) b
-> ErrorA e arr (a, (e, s)) b -> ErrorA e arr (a, s) b
catchA (ErrorA arr (a, s) (Either e b)
f) (ErrorA arr (a, (e, s)) (Either e b)
g) = arr (a, s) (Either e b) -> ErrorA e arr (a, s) b
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA proc (a
a, s
s) -> do
    Either e b
r <- arr (a, s) (Either e b)
f -< (a
a, s
s)
    case Either e b
r of
      Left e
e -> arr (a, (e, s)) (Either e b)
g -< (a
a, (e
e, s
s))
      Right b
v -> arr (Either e b) (Either e b)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< b -> Either e b
forall a b. b -> Either a b
Right b
v
  {-# INLINEABLE catchA #-}

instance (ArrowReader r arr, ArrowChoice arr) => ArrowReader r (ErrorA e arr) where
  askA :: ErrorA e arr a r
askA = arr a r -> ErrorA e arr a r
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr a r
forall r (arr :: * -> * -> *) a. ArrowReader r arr => arr a r
askA
  {-# INLINE askA #-}
  localA :: ErrorA e arr (a, s) b -> ErrorA e arr (a, (r, s)) b
localA (ErrorA arr (a, s) (Either e b)
f) = arr (a, (r, s)) (Either e b) -> ErrorA e arr (a, (r, s)) b
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA (arr (a, s) (Either e b) -> arr (a, (r, s)) (Either e b)
forall r (arr :: * -> * -> *) a s b.
ArrowReader r arr =>
arr (a, s) b -> arr (a, (r, s)) b
localA arr (a, s) (Either e b)
f)
  {-# INLINE localA #-}

instance (ArrowWriter w arr, ArrowChoice arr) => ArrowWriter w (ErrorA e arr) where
  tellA :: ErrorA e arr w ()
tellA = arr w () -> ErrorA e arr w ()
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr w ()
forall w (arr :: * -> * -> *). ArrowWriter w arr => arr w ()
tellA
  {-# INLINE tellA #-}
  listenA :: ErrorA e arr a b -> ErrorA e arr a (b, w)
listenA (ErrorA arr a (Either e b)
f) = arr a (Either e (b, w)) -> ErrorA e arr a (b, w)
forall e (arr :: * -> * -> *) a b.
arr a (Either e b) -> ErrorA e arr a b
ErrorA (((Either e b, w) -> Either e (b, w))
-> arr (Either e b, w) (Either e (b, w))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Either e b, w) -> Either e (b, w)
forall (f :: * -> *) a b. Functor f => (f a, b) -> f (a, b)
sequenceFirst arr (Either e b, w) (Either e (b, w))
-> arr a (Either e b, w) -> arr a (Either e (b, w))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr a (Either e b) -> arr a (Either e b, w)
forall w (arr :: * -> * -> *) a b.
ArrowWriter w arr =>
arr a b -> arr a (b, w)
listenA arr a (Either e b)
f)
  {-# INLINE listenA #-}

newtype ReaderA r arr a b = ReaderA {ReaderA r arr a b -> arr (a, r) b
runReaderA :: arr (a, r) b}

instance (Arrow arr) => Category (ReaderA r arr) where
  id :: ReaderA r arr a a
id = arr (a, r) a -> ReaderA r arr a a
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA (((a, r) -> a) -> arr (a, r) a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (a, r) -> a
forall a b. (a, b) -> a
fst)
  {-# INLINE id #-}
  ReaderA arr (b, r) c
f . :: ReaderA r arr b c -> ReaderA r arr a b -> ReaderA r arr a c
. ReaderA arr (a, r) b
g = arr (a, r) c -> ReaderA r arr a c
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA proc (a
a, r
r) -> do
    b
b <- arr (a, r) b
g -< (a
a, r
r)
    arr (b, r) c
f -< (b
b, r
r)
  {-# INLINE (.) #-}

instance (Arrow arr) => Arrow (ReaderA r arr) where
  arr :: (b -> c) -> ReaderA r arr b c
arr b -> c
f = arr (b, r) c -> ReaderA r arr b c
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA (((b, r) -> c) -> arr (b, r) c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (b -> c
f (b -> c) -> ((b, r) -> b) -> (b, r) -> c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (b, r) -> b
forall a b. (a, b) -> a
fst))
  {-# INLINE arr #-}
  first :: ReaderA r arr b c -> ReaderA r arr (b, d) (c, d)
first (ReaderA arr (b, r) c
f) = arr ((b, d), r) (c, d) -> ReaderA r arr (b, d) (c, d)
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA proc ((b
a, d
c), r
r) -> do
    c
b <- arr (b, r) c
f -< (b
a, r
r)
    arr (c, d) (c, d)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (c
b, d
c)
  {-# INLINE first #-}

instance (ArrowChoice arr) => ArrowChoice (ReaderA r arr) where
  left :: ReaderA r arr b c -> ReaderA r arr (Either b d) (Either c d)
left (ReaderA arr (b, r) c
f) = arr (Either b d, r) (Either c d)
-> ReaderA r arr (Either b d) (Either c d)
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA proc (Either b d
e, r
r) -> case Either b d
e of
    Left b
a -> (c -> Either c d) -> arr c (Either c d)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr c -> Either c d
forall a b. a -> Either a b
Left arr c (Either c d) -> arr (b, r) c -> arr (b, r) (Either c d)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr (b, r) c
f -< (b
a, r
r)
    Right d
b -> arr (Either c d) (Either c d)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< d -> Either c d
forall a b. b -> Either a b
Right d
b
  {-# INLINE left #-}
  ReaderA arr (b, r) d
f ||| :: ReaderA r arr b d
-> ReaderA r arr c d -> ReaderA r arr (Either b c) d
||| ReaderA arr (c, r) d
g = arr (Either b c, r) d -> ReaderA r arr (Either b c) d
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA ((arr (b, r) d
f arr (b, r) d -> arr (c, r) d -> arr (Either (b, r) (c, r)) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| arr (c, r) d
g) arr (Either (b, r) (c, r)) d
-> arr (Either b c, r) (Either (b, r) (c, r))
-> arr (Either b c, r) d
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((Either b c, r) -> Either (b, r) (c, r))
-> arr (Either b c, r) (Either (b, r) (c, r))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr \(Either b c
e, r
r) -> ((,r
r) (b -> (b, r))
-> (c -> (c, r)) -> Either b c -> Either (b, r) (c, r)
forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
+++ (,r
r)) Either b c
e)
  {-# INLINE (|||) #-}

instance (ArrowApply arr) => ArrowApply (ReaderA r arr) where
  app :: ReaderA r arr (ReaderA r arr b c, b) c
app = arr ((ReaderA r arr b c, b), r) c
-> ReaderA r arr (ReaderA r arr b c, b) c
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA (arr (arr (b, r) c, (b, r)) c
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app arr (arr (b, r) c, (b, r)) c
-> arr ((ReaderA r arr b c, b), r) (arr (b, r) c, (b, r))
-> arr ((ReaderA r arr b c, b), r) c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (((ReaderA r arr b c, b), r) -> (arr (b, r) c, (b, r)))
-> arr ((ReaderA r arr b c, b), r) (arr (b, r) c, (b, r))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr \((ReaderA arr (b, r) c
f, b
x), r
r) -> (arr (b, r) c
f, (b
x, r
r)))
  {-# INLINE app #-}

instance (Arrow arr) => ArrowTrans (ReaderA r) arr where
  liftA :: arr a b -> ReaderA r arr a b
liftA arr a b
f = arr (a, r) b -> ReaderA r arr a b
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA (arr a b
f arr a b -> arr (a, r) a -> arr (a, r) b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((a, r) -> a) -> arr (a, r) a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (a, r) -> a
forall a b. (a, b) -> a
fst)
  {-# INLINE liftA #-}

instance (Arrow arr) => ArrowReader r (ReaderA r arr) where
  askA :: ReaderA r arr a r
askA = arr (a, r) r -> ReaderA r arr a r
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA (((a, r) -> r) -> arr (a, r) r
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (a, r) -> r
forall a b. (a, b) -> b
snd)
  {-# INLINE askA #-}
  localA :: ReaderA r arr (a, s) b -> ReaderA r arr (a, (r, s)) b
localA (ReaderA arr ((a, s), r) b
f) = arr ((a, (r, s)), r) b -> ReaderA r arr (a, (r, s)) b
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA proc ((a
a, (r
r, s
s)), r
_) -> arr ((a, s), r) b
f -< ((a
a, s
s), r
r)
  {-# INLINE localA #-}

instance (ArrowError e arr) => ArrowError e (ReaderA r arr) where
  throwA :: ReaderA r arr e a
throwA = arr e a -> ReaderA r arr e a
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr e a
forall e (arr :: * -> * -> *) a. ArrowError e arr => arr e a
throwA
  {-# INLINE throwA #-}
  catchA :: ReaderA r arr (a, s) b
-> ReaderA r arr (a, (e, s)) b -> ReaderA r arr (a, s) b
catchA (ReaderA arr ((a, s), r) b
f) (ReaderA arr ((a, (e, s)), r) b
g) = arr ((a, s), r) b -> ReaderA r arr (a, s) b
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA proc ((a
a, s
s), r
r) ->
    (arr ((a, s), r) b
f -< ((a
a, s
s), r
r)) forall a. arr (a, ()) b -> arr (a, (e, ())) b -> arr (a, ()) b
forall e (arr :: * -> * -> *) a s b.
ArrowError e arr =>
arr (a, s) b -> arr (a, (e, s)) b -> arr (a, s) b
`catchA` \e
e -> arr ((a, (e, s)), r) b
g -< ((a
a, (e
e, s
s)), r
r)
  {-# INLINE catchA #-}

instance (ArrowWriter w arr) => ArrowWriter w (ReaderA r arr) where
  tellA :: ReaderA r arr w ()
tellA = arr w () -> ReaderA r arr w ()
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr w ()
forall w (arr :: * -> * -> *). ArrowWriter w arr => arr w ()
tellA
  {-# INLINE tellA #-}
  listenA :: ReaderA r arr a b -> ReaderA r arr a (b, w)
listenA (ReaderA arr (a, r) b
f) = arr (a, r) (b, w) -> ReaderA r arr a (b, w)
forall r (arr :: * -> * -> *) a b.
arr (a, r) b -> ReaderA r arr a b
ReaderA (arr (a, r) b -> arr (a, r) (b, w)
forall w (arr :: * -> * -> *) a b.
ArrowWriter w arr =>
arr a b -> arr a (b, w)
listenA arr (a, r) b
f)
  {-# INLINE listenA #-}

newtype WriterA w arr a b
  = -- Internally defined using state passing to avoid space leaks. The real constructor should be
    -- left unexported to avoid misuse.
    MkWriterA (arr (a, w) (b, w))

pattern WriterA :: (Monoid w, Arrow arr) => arr a (b, w) -> WriterA w arr a b
pattern $bWriterA :: arr a (b, w) -> WriterA w arr a b
$mWriterA :: forall r w (arr :: * -> * -> *) a b.
(Monoid w, Arrow arr) =>
WriterA w arr a b -> (arr a (b, w) -> r) -> (Void# -> r) -> r
WriterA {WriterA w arr a b -> (Monoid w, Arrow arr) => arr a (b, w)
runWriterA} <-
  MkWriterA (\f -> f . arr (,mempty) -> runWriterA)
  where
    WriterA arr a (b, w)
f = arr (a, w) (b, w) -> WriterA w arr a b
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA ((((b, w), w) -> (b, w)) -> arr ((b, w), w) (b, w)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\((b
b, w
w), w
w1) -> let !w2 :: w
w2 = w
w1 w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w in (b
b, w
w2)) arr ((b, w), w) (b, w)
-> arr (a, w) ((b, w), w) -> arr (a, w) (b, w)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr a (b, w) -> arr (a, w) ((b, w), w)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first arr a (b, w)
f)

{-# COMPLETE WriterA #-}

instance (Category arr) => Category (WriterA w arr) where
  id :: WriterA w arr a a
id = arr (a, w) (a, w) -> WriterA w arr a a
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA arr (a, w) (a, w)
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  {-# INLINE id #-}
  MkWriterA arr (b, w) (c, w)
f . :: WriterA w arr b c -> WriterA w arr a b -> WriterA w arr a c
. MkWriterA arr (a, w) (b, w)
g = arr (a, w) (c, w) -> WriterA w arr a c
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA (arr (b, w) (c, w)
f arr (b, w) (c, w) -> arr (a, w) (b, w) -> arr (a, w) (c, w)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr (a, w) (b, w)
g)
  {-# INLINE (.) #-}

instance (Arrow arr) => Arrow (WriterA w arr) where
  arr :: (b -> c) -> WriterA w arr b c
arr b -> c
f = arr (b, w) (c, w) -> WriterA w arr b c
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA (((b, w) -> (c, w)) -> arr (b, w) (c, w)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (((b, w) -> (c, w)) -> arr (b, w) (c, w))
-> ((b, w) -> (c, w)) -> arr (b, w) (c, w)
forall a b. (a -> b) -> a -> b
$ (b -> c) -> (b, w) -> (c, w)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first b -> c
f)
  {-# INLINE arr #-}
  first :: WriterA w arr b c -> WriterA w arr (b, d) (c, d)
first (MkWriterA arr (b, w) (c, w)
f) = arr ((b, d), w) ((c, d), w) -> WriterA w arr (b, d) (c, d)
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA proc ((b
a1, d
b), w
w1) -> do
    (c
a2, w
w2) <- arr (b, w) (c, w)
f -< (b
a1, w
w1)
    arr ((c, d), w) ((c, d), w)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ((c
a2, d
b), w
w2)
  {-# INLINE first #-}

instance (ArrowChoice arr) => ArrowChoice (WriterA w arr) where
  left :: WriterA w arr b c -> WriterA w arr (Either b d) (Either c d)
left (MkWriterA arr (b, w) (c, w)
f) = arr (Either b d, w) (Either c d, w)
-> WriterA w arr (Either b d) (Either c d)
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA proc (Either b d
e, w
w) -> case Either b d
e of
    Left b
a -> ((c, w) -> (Either c d, w)) -> arr (c, w) (Either c d, w)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((c -> Either c d) -> (c, w) -> (Either c d, w)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first c -> Either c d
forall a b. a -> Either a b
Left) arr (c, w) (Either c d, w)
-> arr (b, w) (c, w) -> arr (b, w) (Either c d, w)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr (b, w) (c, w)
f -< (b
a, w
w)
    Right d
b -> arr (Either c d, w) (Either c d, w)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (d -> Either c d
forall a b. b -> Either a b
Right d
b, w
w)
  {-# INLINE left #-}
  WriterA w arr b d
f ||| :: WriterA w arr b d
-> WriterA w arr c d -> WriterA w arr (Either b c) d
||| WriterA w arr c d
g = (Either d d -> d) -> WriterA w arr (Either d d) d
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((d -> d) -> (d -> d) -> Either d d -> d
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either d -> d
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id d -> d
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id) WriterA w arr (Either d d) d
-> WriterA w arr (Either b c) (Either d d)
-> WriterA w arr (Either b c) d
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WriterA w arr c d -> WriterA w arr (Either d c) (Either d d)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right WriterA w arr c d
g WriterA w arr (Either d c) (Either d d)
-> WriterA w arr (Either b c) (Either d c)
-> WriterA w arr (Either b c) (Either d d)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WriterA w arr b d -> WriterA w arr (Either b c) (Either d c)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left WriterA w arr b d
f
  {-# INLINE (|||) #-}

instance (ArrowApply arr) => ArrowApply (WriterA w arr) where
  app :: WriterA w arr (WriterA w arr b c, b) c
app = arr ((WriterA w arr b c, b), w) (c, w)
-> WriterA w arr (WriterA w arr b c, b) c
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA (arr (arr (b, w) (c, w), (b, w)) (c, w)
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app arr (arr (b, w) (c, w), (b, w)) (c, w)
-> arr ((WriterA w arr b c, b), w) (arr (b, w) (c, w), (b, w))
-> arr ((WriterA w arr b c, b), w) (c, w)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (((WriterA w arr b c, b), w) -> (arr (b, w) (c, w), (b, w)))
-> arr ((WriterA w arr b c, b), w) (arr (b, w) (c, w), (b, w))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr \((MkWriterA arr (b, w) (c, w)
f, b
x), w
w) -> (arr (b, w) (c, w)
f, (b
x, w
w)))
  {-# INLINE app #-}

instance (Arrow arr) => ArrowTrans (WriterA w) arr where
  liftA :: arr a b -> WriterA w arr a b
liftA = arr (a, w) (b, w) -> WriterA w arr a b
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA (arr (a, w) (b, w) -> WriterA w arr a b)
-> (arr a b -> arr (a, w) (b, w)) -> arr a b -> WriterA w arr a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr a b -> arr (a, w) (b, w)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first
  {-# INLINE liftA #-}

instance (Monoid w, Arrow arr) => ArrowWriter w (WriterA w arr) where
  tellA :: WriterA w arr w ()
tellA = arr (w, w) ((), w) -> WriterA w arr w ()
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA (arr (w, w) ((), w) -> WriterA w arr w ())
-> arr (w, w) ((), w) -> WriterA w arr w ()
forall a b. (a -> b) -> a -> b
$ ((w, w) -> ((), w)) -> arr (w, w) ((), w)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr \(w
w, w
w1) -> let !w2 :: w
w2 = w
w1 w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w in ((), w
w2)
  listenA :: WriterA w arr a b -> WriterA w arr a (b, w)
listenA (WriterA arr a (b, w)
f) = arr a ((b, w), w) -> WriterA w arr a (b, w)
forall w (arr :: * -> * -> *) a b.
(Monoid w, Arrow arr) =>
arr a (b, w) -> WriterA w arr a b
WriterA (((b, w) -> ((b, w), w)) -> arr (b, w) ((b, w), w)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(b
a, w
w) -> ((b
a, w
w), w
w)) arr (b, w) ((b, w), w) -> arr a (b, w) -> arr a ((b, w), w)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. arr a (b, w)
f)
  {-# INLINE listenA #-}

instance (ArrowError e arr) => ArrowError e (WriterA w arr) where
  throwA :: WriterA w arr e a
throwA = arr e a -> WriterA w arr e a
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr e a
forall e (arr :: * -> * -> *) a. ArrowError e arr => arr e a
throwA
  {-# INLINE throwA #-}
  catchA :: WriterA w arr (a, s) b
-> WriterA w arr (a, (e, s)) b -> WriterA w arr (a, s) b
catchA (MkWriterA arr ((a, s), w) (b, w)
f) (MkWriterA arr ((a, (e, s)), w) (b, w)
g) = arr ((a, s), w) (b, w) -> WriterA w arr (a, s) b
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA proc ((a
a, s
s), w
w) ->
    (arr ((a, s), w) (b, w)
f -< ((a
a, s
s), w
w)) forall a.
arr (a, ()) (b, w) -> arr (a, (e, ())) (b, w) -> arr (a, ()) (b, w)
forall e (arr :: * -> * -> *) a s b.
ArrowError e arr =>
arr (a, s) b -> arr (a, (e, s)) b -> arr (a, s) b
`catchA` \e
e -> arr ((a, (e, s)), w) (b, w)
g -< ((a
a, (e
e, s
s)), w
w)
  {-# INLINE catchA #-}

instance (ArrowReader r arr) => ArrowReader r (WriterA w arr) where
  askA :: WriterA w arr a r
askA = arr a r -> WriterA w arr a r
forall (t :: (* -> * -> *) -> * -> * -> *) (arr :: * -> * -> *) a
       b.
ArrowTrans t arr =>
arr a b -> t arr a b
liftA arr a r
forall r (arr :: * -> * -> *) a. ArrowReader r arr => arr a r
askA
  {-# INLINE askA #-}
  localA :: WriterA w arr (a, s) b -> WriterA w arr (a, (r, s)) b
localA (MkWriterA arr ((a, s), w) (b, w)
f) = arr ((a, (r, s)), w) (b, w) -> WriterA w arr (a, (r, s)) b
forall w (arr :: * -> * -> *) a b.
arr (a, w) (b, w) -> WriterA w arr a b
MkWriterA proc ((a
a, (r
r, s
s)), w
w) -> (| forall a. arr (a, ()) (b, w) -> arr (a, (r, ())) (b, w)
forall r (arr :: * -> * -> *) a s b.
ArrowReader r arr =>
arr (a, s) b -> arr (a, (r, s)) b
localA (arr ((a, s), w) (b, w)
f -< ((a
a, s
s), w
w)) |) r
r
  {-# INLINE localA #-}