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

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Arrow.Transformer.Reader
-- 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)
--
-- Arrow transformer that adds a read-only state (i.e. an environment).

module Control.Arrow.Transformer.Reader(
    ReaderArrow(ReaderArrow),
    runReader,
    ArrowAddReader(..),
    ) 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 type that augments an existing arrow with a read-only state
-- (or environment).  The 'ArrowReader' class contains the operations
-- on this state.

newtype ReaderArrow r a b c = ReaderArrow (a (b, r) c)

-- | Encapsulation of a state-reading computation, taking a value for the
-- state.
--
-- Typical usage in arrow notation:
--
-- >    proc p -> ...
-- >        (|runReader cmd|) env

runReader :: Arrow a => ReaderArrow r a e b -> a (e,r) b
runReader :: forall (a :: * -> * -> *) r e b.
Arrow a =>
ReaderArrow r a e b -> a (e, r) b
runReader (ReaderArrow a (e, r) b
f) = a (e, r) b
f

-- arrow transformer

instance Arrow a => ArrowTransformer (ReaderArrow r) a where
    lift :: forall b c. a b c -> ReaderArrow r a b c
lift a b c
f = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a, b) -> a
fst forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a b c
f)

-- liftings of standard classes

instance Arrow a => Category (ReaderArrow r a) where
    id :: forall a. ReaderArrow r a a a
id = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a, b) -> a
fst)
    ReaderArrow a (b, r) c
f . :: forall b c a.
ReaderArrow r a b c -> ReaderArrow r a a b -> ReaderArrow r a a c
. ReaderArrow a (a, r) b
g = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (a (b, r) c
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a (a, r) b
g forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall {a} {b}. (a, b) -> ((a, b), b)
dupenv)
      where
        dupenv :: (a, b) -> ((a, b), b)
dupenv (a
a, b
r) = ((a
a, b
r), b
r)

instance Arrow a => Arrow (ReaderArrow r a) where
    arr :: forall b c. (b -> c) -> ReaderArrow r a b c
arr b -> c
f = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (b -> c
f forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (a, b) -> a
fst))
    first :: forall b c d. ReaderArrow r a b c -> ReaderArrow r a (b, d) (c, d)
first (ReaderArrow a (b, r) c
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a r b. ((a, r), b) -> ((a, b), r)
swapsnd forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a (b, r) c
f)

swapsnd :: ((a, r), b) -> ((a, b), r)
swapsnd :: forall a r b. ((a, r), b) -> ((a, b), r)
swapsnd ~(~(a
a, r
r), b
b) = ((a
a, b
b), r
r)

instance ArrowChoice a => ArrowChoice (ReaderArrow r a) where
    left :: forall b c d.
ReaderArrow r a b c -> ReaderArrow r a (Either b d) (Either c d)
left (ReaderArrow a (b, r) c
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall b c r. (Either b c, r) -> Either (b, r) c
dist' forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left a (b, r) c
f)
      where
        dist' :: (Either b c, r) -> Either (b, r) c
        dist' :: forall b c r. (Either b c, r) -> Either (b, r) c
dist' (Left b
b, r
r) = forall a b. a -> Either a b
Left (b
b, r
r)
        dist' (Right c
c, r
_) = forall a b. b -> Either a b
Right c
c

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

instance ArrowZero a => ArrowZero (ReaderArrow r a) where
    zeroArrow :: forall b c. ReaderArrow r a b c
zeroArrow = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow

instance ArrowPlus a => ArrowPlus (ReaderArrow r a) where
    ReaderArrow a (b, r) c
f <+> :: forall b c.
ReaderArrow r a b c -> ReaderArrow r a b c -> ReaderArrow r a b c
<+> ReaderArrow a (b, r) c
g = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (a (b, r) c
f forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> a (b, r) c
g)

instance ArrowLoop a => ArrowLoop (ReaderArrow r a) where
    loop :: forall b d c. ReaderArrow r a (b, d) (c, d) -> ReaderArrow r a b c
loop (ReaderArrow a ((b, d), r) (c, d)
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall (a :: * -> * -> *) b d c.
ArrowLoop a =>
a (b, d) (c, d) -> a b c
loop (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a r b. ((a, r), b) -> ((a, b), r)
swapsnd forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a ((b, d), r) (c, d)
f))

-- new instances

instance Arrow a => ArrowReader r (ReaderArrow r a) where
    readState :: forall b. ReaderArrow r a b r
readState = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a, b) -> b
snd)
    newReader :: forall e b. ReaderArrow r a e b -> ReaderArrow r a (e, r) b
newReader (ReaderArrow a (e, r) b
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a, b) -> a
fst forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a (e, r) b
f)

instance Arrow a => ArrowAddReader r (ReaderArrow r a) a where
    liftReader :: forall e b. a e b -> ReaderArrow r a e b
liftReader = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift
    elimReader :: forall e b. ReaderArrow r a e b -> a (e, r) b
elimReader = forall (a :: * -> * -> *) r e b.
Arrow a =>
ReaderArrow r a e b -> a (e, r) b
runReader

-- liftings of other classes

instance ArrowCircuit a => ArrowCircuit (ReaderArrow r a) where
    delay :: forall b. b -> ReaderArrow r a b b
delay b
x = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift (forall (a :: * -> * -> *) b. ArrowCircuit a => b -> a b b
delay b
x)

instance ArrowError ex a => ArrowError ex (ReaderArrow r a) where
    raise :: forall b. ReaderArrow r a ex b
raise = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall ex (a :: * -> * -> *) b. ArrowError ex a => a ex b
raise
    handle :: forall e b.
ReaderArrow r a e b
-> ReaderArrow r a (e, ex) b -> ReaderArrow r a e b
handle (ReaderArrow a (e, r) b
f) (ReaderArrow a ((e, ex), r) b
h) =
        forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall ex (a :: * -> * -> *) e b.
ArrowError ex a =>
a e b -> a (e, ex) b -> a e b
handle a (e, r) b
f (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a r b. ((a, r), b) -> ((a, b), r)
swapsnd 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), r) b
h))
    tryInUnless :: forall e b c.
ReaderArrow r a e b
-> ReaderArrow r a (e, b) c
-> ReaderArrow r a (e, ex) c
-> ReaderArrow r a e c
tryInUnless (ReaderArrow a (e, r) b
f) (ReaderArrow a ((e, b), r) c
s) (ReaderArrow a ((e, ex), r) c
h) =
        forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall ex (a :: * -> * -> *) e b c.
ArrowError ex a =>
a e b -> a (e, b) c -> a (e, ex) c -> a e c
tryInUnless a (e, r) b
f (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a r b. ((a, r), b) -> ((a, b), r)
swapsnd forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a ((e, b), r) c
s) (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a r b. ((a, r), b) -> ((a, b), r)
swapsnd 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), r) c
h))
    newError :: forall e b. ReaderArrow r a e b -> ReaderArrow r a e (Either ex b)
newError (ReaderArrow a (e, r) b
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall ex (a :: * -> * -> *) e b.
ArrowError ex a =>
a e b -> a e (Either ex b)
newError a (e, r) b
f)

instance ArrowState s a => ArrowState s (ReaderArrow r a) where
    fetch :: forall e. ReaderArrow r a e s
fetch = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall s (a :: * -> * -> *) e. ArrowState s a => a e s
fetch
    store :: ReaderArrow r a s ()
store = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall s (a :: * -> * -> *). ArrowState s a => a s ()
store

instance ArrowWriter s a => ArrowWriter s (ReaderArrow r a) where
    write :: ReaderArrow r a s ()
write = forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift forall w (a :: * -> * -> *). ArrowWriter w a => a w ()
write
    newWriter :: forall e b. ReaderArrow r a e b -> ReaderArrow r a e (b, s)
newWriter (ReaderArrow a (e, r) b
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall w (a :: * -> * -> *) e b.
ArrowWriter w a =>
a e b -> a e (b, w)
newWriter a (e, r) b
f)

-- Promotions of encapsulation operators.

instance ArrowAddError ex a a' =>
        ArrowAddError ex (ReaderArrow r a) (ReaderArrow r a') where
    liftError :: forall e b. ReaderArrow r a' e b -> ReaderArrow r a e b
liftError (ReaderArrow a' (e, r) b
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall ex (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddError ex a a' =>
a' e b -> a e b
liftError a' (e, r) b
f)
    elimError :: forall e b.
ReaderArrow r a e b
-> ReaderArrow r a' (e, ex) b -> ReaderArrow r a' e b
elimError (ReaderArrow a (e, r) b
f) (ReaderArrow a' ((e, ex), r) b
h) =
        forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall ex (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddError ex a a' =>
a e b -> a' (e, ex) b -> a' e b
elimError a (e, r) b
f (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a r b. ((a, r), b) -> ((a, b), r)
swapsnd 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), r) b
h))

instance ArrowAddState s a a' =>
        ArrowAddState s (ReaderArrow r a) (ReaderArrow r a') where
    liftState :: forall e b. ReaderArrow r a' e b -> ReaderArrow r a e b
liftState (ReaderArrow a' (e, r) b
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall s (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddState s a a' =>
a' e b -> a e b
liftState a' (e, r) b
f)
    elimState :: forall e b. ReaderArrow r a e b -> ReaderArrow r a' (e, s) (b, s)
elimState (ReaderArrow a (e, r) b
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a r b. ((a, r), b) -> ((a, b), r)
swapsnd forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall s (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddState s a a' =>
a e b -> a' (e, s) (b, s)
elimState a (e, r) b
f)

-- instance ArrowAddReader r a a' =>
--         ArrowAddReader r (ReaderArrow r a) (ReaderArrow r a') where
--     elimReader (ReaderArrow f) = ReaderArrow (arr swapsnd >>> elimReader f)

instance ArrowAddWriter s a a' =>
        ArrowAddWriter s (ReaderArrow r a) (ReaderArrow r a') where
    liftWriter :: forall e b. ReaderArrow r a' e b -> ReaderArrow r a e b
liftWriter (ReaderArrow a' (e, r) b
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall w (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddWriter w a a' =>
a' e b -> a e b
liftWriter a' (e, r) b
f)
    elimWriter :: forall e b. ReaderArrow r a e b -> ReaderArrow r a' e (b, s)
elimWriter (ReaderArrow a (e, r) b
f) = forall r (a :: * -> * -> *) b c. a (b, r) c -> ReaderArrow r a b c
ReaderArrow (forall w (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddWriter w a a' =>
a e b -> a' e (b, w)
elimWriter a (e, r) b
f)

-- Other instances

instance Arrow a => Functor (ReaderArrow r a b) where
    fmap :: forall a b. (a -> b) -> ReaderArrow r a b a -> ReaderArrow r a b b
fmap a -> b
f ReaderArrow r a b a
g = ReaderArrow r a b a
g forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f

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

instance ArrowPlus a => Alternative (ReaderArrow r a b) where
    empty :: forall a. ReaderArrow r a b a
empty = forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
    ReaderArrow r a b a
f <|> :: forall a.
ReaderArrow r a b a -> ReaderArrow r a b a -> ReaderArrow r a b a
<|> ReaderArrow r a b a
g = ReaderArrow r a b a
f forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> ReaderArrow r a b a
g

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

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