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

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Arrow.Transformer.State
-- 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 a modifiable state,
-- based of section 9 of /Generalising Monads to Arrows/, by John Hughes,
-- /Science of Computer Programming/ 37:67-111, May 2000.

module Control.Arrow.Transformer.State(
    StateArrow(StateArrow),
    runState,
    ArrowAddState(..),
    ) 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 modifiable
-- state.  The 'ArrowState' class contains the operations on this state.

newtype StateArrow s a b c = StateArrow (a (b, s) (c, s))

swapsnd :: ((a, b), c) -> ((a, c), b)
swapsnd :: ((a, b), c) -> ((a, c), b)
swapsnd ~(~(a
x, b
y), c
z) = ((a
x, c
z), b
y)

instance Category a => Category (StateArrow s a) where
    id :: StateArrow s a a a
id = a (a, s) (a, s) -> StateArrow s a a a
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow a (a, s) (a, s)
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
    StateArrow a (b, s) (c, s)
f . :: StateArrow s a b c -> StateArrow s a a b -> StateArrow s a a c
. StateArrow a (a, s) (b, s)
g = a (a, s) (c, s) -> StateArrow s a a c
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (a (b, s) (c, s)
f a (b, s) (c, s) -> a (a, s) (b, s) -> a (a, s) (c, s)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a (a, s) (b, s)
g)

instance Arrow a => Arrow (StateArrow s a) where
    arr :: (b -> c) -> StateArrow s a b c
arr b -> c
f = a (b, s) (c, s) -> StateArrow s a b c
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (((b, s) -> (c, s)) -> a (b, s) (c, s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(b
x, s
s) -> (b -> c
f b
x, s
s)))
    first :: StateArrow s a b c -> StateArrow s a (b, d) (c, d)
first (StateArrow a (b, s) (c, s)
f) =
        a ((b, d), s) ((c, d), s) -> StateArrow s a (b, d) (c, d)
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow ((((b, d), s) -> ((b, s), d)) -> a ((b, d), s) ((b, s), d)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b, d), s) -> ((b, s), d)
forall a b c. ((a, b), c) -> ((a, c), b)
swapsnd a ((b, d), s) ((b, s), d)
-> a ((b, s), d) ((c, d), s) -> a ((b, d), s) ((c, d), s)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a (b, s) (c, s) -> a ((b, s), d) ((c, s), d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a (b, s) (c, s)
f a ((b, s), d) ((c, s), d)
-> a ((c, s), d) ((c, d), s) -> a ((b, s), d) ((c, d), s)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (((c, s), d) -> ((c, d), s)) -> a ((c, s), d) ((c, d), s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((c, s), d) -> ((c, d), s)
forall a b c. ((a, b), c) -> ((a, c), b)
swapsnd)

instance Arrow a => ArrowTransformer (StateArrow s) a where
    lift :: a b c -> StateArrow s a b c
lift a b c
f = a (b, s) (c, s) -> StateArrow s a b c
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (a b c -> a (b, s) (c, s)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a b c
f)

-- | Encapsulation of a state-using computation, exposing the initial
-- and final states.
--
-- Typical usage in arrow notation:
--
-- >    proc p -> do
-- >        ...
-- >        (result, final_state) <- (|runState cmd|) init_state

runState :: Arrow a => StateArrow s a e b -> a (e,s) (b,s)
runState :: StateArrow s a e b -> a (e, s) (b, s)
runState (StateArrow a (e, s) (b, s)
f) = a (e, s) (b, s)
f

-- operations

instance Arrow a => ArrowState s (StateArrow s a) where
    fetch :: StateArrow s a e s
fetch = a (e, s) (s, s) -> StateArrow s a e s
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (((e, s) -> (s, s)) -> a (e, s) (s, s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(e
_, s
s) -> (s
s, s
s)))
    store :: StateArrow s a s ()
store = a (s, s) ((), s) -> StateArrow s a s ()
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (((s, s) -> ((), s)) -> a (s, s) ((), s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(s
s, s
_) -> ((), s
s)))

instance Arrow a => ArrowAddState s (StateArrow s a) a where
    liftState :: a e b -> StateArrow s a e b
liftState = a e b -> StateArrow s a e b
forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift
    elimState :: StateArrow s a e b -> a (e, s) (b, s)
elimState = StateArrow s a e b -> a (e, s) (b, s)
forall (a :: * -> * -> *) s e b.
Arrow a =>
StateArrow s a e b -> a (e, s) (b, s)
runState

-- The following promotions follow directly from the arrow transformer.

instance ArrowZero a => ArrowZero (StateArrow s a) where
    zeroArrow :: StateArrow s a b c
zeroArrow = a (b, s) (c, s) -> StateArrow s a b c
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow a (b, s) (c, s)
forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow

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

instance ArrowError ex a => ArrowError ex (StateArrow s a) where
    raise :: StateArrow s a ex b
raise = a ex b -> StateArrow s a ex b
forall (f :: (* -> * -> *) -> * -> * -> *) (a :: * -> * -> *) b c.
ArrowTransformer f a =>
a b c -> f a b c
lift a ex b
forall ex (a :: * -> * -> *) b. ArrowError ex a => a ex b
raise
    handle :: StateArrow s a e b
-> StateArrow s a (e, ex) b -> StateArrow s a e b
handle (StateArrow a (e, s) (b, s)
f) (StateArrow a ((e, ex), s) (b, s)
h) =
        a (e, s) (b, s) -> StateArrow s a e b
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (a (e, s) (b, s) -> a ((e, s), ex) (b, s) -> a (e, s) (b, s)
forall ex (a :: * -> * -> *) e b.
ArrowError ex a =>
a e b -> a (e, ex) b -> a e b
handle a (e, s) (b, s)
f ((((e, s), ex) -> ((e, ex), s)) -> a ((e, s), ex) ((e, ex), s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((e, s), ex) -> ((e, ex), s)
forall a b c. ((a, b), c) -> ((a, c), b)
swapsnd a ((e, s), ex) ((e, ex), s)
-> a ((e, ex), s) (b, s) -> a ((e, s), 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
>>> a ((e, ex), s) (b, s)
h))
    tryInUnless :: StateArrow s a e b
-> StateArrow s a (e, b) c
-> StateArrow s a (e, ex) c
-> StateArrow s a e c
tryInUnless (StateArrow a (e, s) (b, s)
f) (StateArrow a ((e, b), s) (c, s)
s) (StateArrow a ((e, ex), s) (c, s)
h) =
        a (e, s) (c, s) -> StateArrow s a e c
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (a (e, s) (b, s)
-> a ((e, s), (b, s)) (c, s)
-> a ((e, s), ex) (c, s)
-> a (e, s) (c, s)
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, s) (b, s)
f ((((e, s), (b, s)) -> ((e, b), s)) -> a ((e, s), (b, s)) ((e, b), s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((e, s), (b, s)) -> ((e, b), s)
forall a b b b. ((a, b), (b, b)) -> ((a, b), b)
new_state a ((e, s), (b, s)) ((e, b), s)
-> a ((e, b), s) (c, s) -> a ((e, s), (b, s)) (c, s)
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), s) (c, s)
s) ((((e, s), ex) -> ((e, ex), s)) -> a ((e, s), ex) ((e, ex), s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((e, s), ex) -> ((e, ex), s)
forall a b c. ((a, b), c) -> ((a, c), b)
swapsnd a ((e, s), ex) ((e, ex), s)
-> a ((e, ex), s) (c, s) -> a ((e, s), ex) (c, s)
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), s) (c, s)
h))
      where
        new_state :: ((a, b), (b, b)) -> ((a, b), b)
new_state ((a
b,b
_),(b
c,b
s')) = ((a
b,b
c),b
s')
    newError :: StateArrow s a e b -> StateArrow s a e (Either ex b)
newError (StateArrow a (e, s) (b, s)
f) = a (e, s) (Either ex b, s) -> StateArrow s a e (Either ex b)
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (a (e, s) (b, s) -> a (e, s) (Either ex (b, s))
forall ex (a :: * -> * -> *) e b.
ArrowError ex a =>
a e b -> a e (Either ex b)
newError a (e, s) (b, s)
f a (e, s) (Either ex (b, s))
-> a (e, s) s -> a (e, s) (Either ex (b, s), s)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((e, s) -> s) -> a (e, s) s
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (e, s) -> s
forall a b. (a, b) -> b
snd a (e, s) (Either ex (b, s), s)
-> a (Either ex (b, s), 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), s) -> (Either ex b, s))
-> a (Either ex (b, s), s) (Either ex b, s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Either ex (b, s), s) -> (Either ex b, s)
forall a b b. (Either a (b, b), b) -> (Either a b, b)
h)
      where
        h :: (Either a (b, b), b) -> (Either a b, b)
h (Left a
ex, b
s) = (a -> Either a b
forall a b. a -> Either a b
Left a
ex, b
s)
        h (Right (b
c, b
s'), b
_) = (b -> Either a b
forall a b. b -> Either a b
Right b
c, b
s')

-- Note that in each case the error handler gets the original state.

instance ArrowReader r a => ArrowReader r (StateArrow s a) where
    readState :: StateArrow s a b r
readState = a b r -> StateArrow s 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 :: StateArrow s a e b -> StateArrow s a (e, r) b
newReader (StateArrow a (e, s) (b, s)
f) = a ((e, r), s) (b, s) -> StateArrow s a (e, r) b
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow ((((e, r), s) -> ((e, s), r)) -> a ((e, r), s) ((e, s), r)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((e, r), s) -> ((e, s), r)
forall a b c. ((a, b), c) -> ((a, c), b)
swapsnd a ((e, r), s) ((e, s), r)
-> a ((e, s), r) (b, s) -> a ((e, r), s) (b, s)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a (e, s) (b, s) -> a ((e, s), r) (b, s)
forall r (a :: * -> * -> *) e b.
ArrowReader r a =>
a e b -> a (e, r) b
newReader a (e, s) (b, s)
f)

instance ArrowWriter w a => ArrowWriter w (StateArrow s a) where
    write :: StateArrow s a w ()
write = a w () -> StateArrow s 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 :: StateArrow s a e b -> StateArrow s a e (b, w)
newWriter (StateArrow a (e, s) (b, s)
f) = a (e, s) ((b, w), s) -> StateArrow s a e (b, w)
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (a (e, s) (b, s) -> a (e, s) ((b, s), w)
forall w (a :: * -> * -> *) e b.
ArrowWriter w a =>
a e b -> a e (b, w)
newWriter a (e, s) (b, s)
f a (e, s) ((b, s), w)
-> a ((b, s), w) ((b, w), s) -> a (e, s) ((b, w), s)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (((b, s), w) -> ((b, w), s)) -> a ((b, s), w) ((b, w), s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b, s), w) -> ((b, w), s)
forall a b c. ((a, b), c) -> ((a, c), b)
swapsnd)

-- liftings of standard classes

instance ArrowChoice a => ArrowChoice (StateArrow s a) where
    left :: StateArrow s a b c -> StateArrow s a (Either b d) (Either c d)
left (StateArrow a (b, s) (c, s)
f) = a (Either b d, s) (Either c d, s)
-> StateArrow s a (Either b d) (Either c d)
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (((Either b d, s) -> Either (b, s) (d, s))
-> a (Either b d, s) (Either (b, s) (d, s))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Either b d, s) -> Either (b, s) (d, s)
forall a a b. (Either a a, b) -> Either (a, b) (a, b)
distr a (Either b d, s) (Either (b, s) (d, s))
-> a (Either (b, s) (d, s)) (Either c d, s)
-> a (Either b d, s) (Either c d, s)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a (b, s) (c, s) -> a (Either (b, s) (d, s)) (Either (c, s) (d, s))
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left a (b, s) (c, s)
f a (Either (b, s) (d, s)) (Either (c, s) (d, s))
-> a (Either (c, s) (d, s)) (Either c d, s)
-> a (Either (b, s) (d, s)) (Either c d, s)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Either (c, s) (d, s) -> (Either c d, s))
-> a (Either (c, s) (d, s)) (Either c d, s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Either (c, s) (d, s) -> (Either c d, s)
forall a b b. Either (a, b) (b, b) -> (Either a b, b)
undistr)
      where
        distr :: (Either a a, b) -> Either (a, b) (a, b)
distr (Left a
y, b
s) = (a, b) -> Either (a, b) (a, b)
forall a b. a -> Either a b
Left (a
y, b
s)
        distr (Right a
z, b
s) = (a, b) -> Either (a, b) (a, b)
forall a b. b -> Either a b
Right (a
z, b
s)
        undistr :: Either (a, b) (b, b) -> (Either a b, b)
undistr (Left (a
y, b
s)) = (a -> Either a b
forall a b. a -> Either a b
Left a
y, b
s)
        undistr (Right (b
z, b
s)) = (b -> Either a b
forall a b. b -> Either a b
Right b
z, b
s)

instance ArrowApply a => ArrowApply (StateArrow s a) where
    app :: StateArrow s a (StateArrow s a b c, b) c
app = a ((StateArrow s a b c, b), s) (c, s)
-> StateArrow s a (StateArrow s a b c, b) c
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow ((((StateArrow s a b c, b), s) -> (a (b, s) (c, s), (b, s)))
-> a ((StateArrow s a b c, b), s) (a (b, s) (c, s), (b, s))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\((StateArrow a (b, s) (c, s)
f, b
x), s
s) -> (a (b, s) (c, s)
f, (b
x, s
s))) a ((StateArrow s a b c, b), s) (a (b, s) (c, s), (b, s))
-> a (a (b, s) (c, s), (b, s)) (c, s)
-> a ((StateArrow s a b c, b), s) (c, s)
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, s) (c, s), (b, s)) (c, s)
forall (a :: * -> * -> *) b c. ArrowApply a => a (a b c, b) c
app)

instance ArrowLoop a => ArrowLoop (StateArrow s a) where
    loop :: StateArrow s a (b, d) (c, d) -> StateArrow s a b c
loop (StateArrow a ((b, d), s) ((c, d), s)
f) =
        a (b, s) (c, s) -> StateArrow s a b c
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (a ((b, s), d) ((c, s), d) -> a (b, s) (c, s)
forall (a :: * -> * -> *) b d c.
ArrowLoop a =>
a (b, d) (c, d) -> a b c
loop ((((b, s), d) -> ((b, d), s)) -> a ((b, s), d) ((b, d), s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b, s), d) -> ((b, d), s)
forall a b c. ((a, b), c) -> ((a, c), b)
swapsnd a ((b, s), d) ((b, d), s)
-> a ((b, d), s) ((c, s), d) -> a ((b, s), d) ((c, s), d)
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), s) ((c, d), s)
f a ((b, d), s) ((c, d), s)
-> a ((c, d), s) ((c, s), d) -> a ((b, d), s) ((c, s), d)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (((c, d), s) -> ((c, s), d)) -> a ((c, d), s) ((c, s), d)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((c, d), s) -> ((c, s), d)
forall a b c. ((a, b), c) -> ((a, c), b)
swapsnd))

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

-- Other instances

instance Arrow a => Functor (StateArrow s a b) where
    fmap :: (a -> b) -> StateArrow s a b a -> StateArrow s a b b
fmap a -> b
f StateArrow s a b a
g = StateArrow s a b a
g StateArrow s a b a -> StateArrow s a a b -> StateArrow s 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) -> StateArrow s a a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f

instance Arrow a => Applicative (StateArrow s a b) where
    pure :: a -> StateArrow s a b a
pure a
x = (b -> a) -> StateArrow s 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)
    StateArrow s a b (a -> b)
f <*> :: StateArrow s a b (a -> b)
-> StateArrow s a b a -> StateArrow s a b b
<*> StateArrow s a b a
g = StateArrow s a b (a -> b)
f StateArrow s a b (a -> b)
-> StateArrow s a b a -> StateArrow s a b (a -> b, a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& StateArrow s a b a
g StateArrow s a b (a -> b, a)
-> StateArrow s a (a -> b, a) b -> StateArrow s 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) -> StateArrow s 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 ArrowPlus a => Alternative (StateArrow s a b) where
    empty :: StateArrow s a b a
empty = StateArrow s a b a
forall (a :: * -> * -> *) b c. ArrowZero a => a b c
zeroArrow
    StateArrow s a b a
f <|> :: StateArrow s a b a -> StateArrow s a b a -> StateArrow s a b a
<|> StateArrow s a b a
g = StateArrow s a b a
f StateArrow s a b a -> StateArrow s a b a -> StateArrow s a b a
forall (a :: * -> * -> *) b c.
ArrowPlus a =>
a b c -> a b c -> a b c
<+> StateArrow s a b a
g

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

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

-- promotions

instance ArrowAddReader r a a' =>
        ArrowAddReader r (StateArrow s a) (StateArrow s a') where
    liftReader :: StateArrow s a' e b -> StateArrow s a e b
liftReader (StateArrow a' (e, s) (b, s)
f) = a (e, s) (b, s) -> StateArrow s a e b
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (a' (e, s) (b, s) -> a (e, s) (b, s)
forall r (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddReader r a a' =>
a' e b -> a e b
liftReader a' (e, s) (b, s)
f)
    elimReader :: StateArrow s a e b -> StateArrow s a' (e, r) b
elimReader (StateArrow a (e, s) (b, s)
f) = a' ((e, r), s) (b, s) -> StateArrow s a' (e, r) b
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow ((((e, r), s) -> ((e, s), r)) -> a' ((e, r), s) ((e, s), r)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((e, r), s) -> ((e, s), r)
forall a b c. ((a, b), c) -> ((a, c), b)
swapsnd a' ((e, r), s) ((e, s), r)
-> a' ((e, s), r) (b, s) -> a' ((e, r), s) (b, s)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a (e, s) (b, s) -> a' ((e, s), r) (b, s)
forall r (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddReader r a a' =>
a e b -> a' (e, r) b
elimReader a (e, s) (b, s)
f)

instance ArrowAddWriter w a a' =>
        ArrowAddWriter w (StateArrow s a) (StateArrow s a') where
    liftWriter :: StateArrow s a' e b -> StateArrow s a e b
liftWriter (StateArrow a' (e, s) (b, s)
f) = a (e, s) (b, s) -> StateArrow s a e b
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (a' (e, s) (b, s) -> a (e, s) (b, s)
forall w (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddWriter w a a' =>
a' e b -> a e b
liftWriter a' (e, s) (b, s)
f)
    elimWriter :: StateArrow s a e b -> StateArrow s a' e (b, w)
elimWriter (StateArrow a (e, s) (b, s)
f) = a' (e, s) ((b, w), s) -> StateArrow s a' e (b, w)
forall s (a :: * -> * -> *) b c.
a (b, s) (c, s) -> StateArrow s a b c
StateArrow (a (e, s) (b, s) -> a' (e, s) ((b, s), w)
forall w (a :: * -> * -> *) (a' :: * -> * -> *) e b.
ArrowAddWriter w a a' =>
a e b -> a' e (b, w)
elimWriter a (e, s) (b, s)
f a' (e, s) ((b, s), w)
-> a' ((b, s), w) ((b, w), s) -> a' (e, s) ((b, w), s)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (((b, s), w) -> ((b, w), s)) -> a' ((b, s), w) ((b, w), s)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b, s), w) -> ((b, w), s)
forall a b c. ((a, b), c) -> ((a, c), b)
swapsnd)

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