{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Arrow.Transformer.CoState
-- 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)
--
-- Transformation of state readers.
--
-- /TODO:/ define operations for this arrow.

module Control.Arrow.Transformer.CoState(
    CoStateArrow(CoStateArrow),
    ) where

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

import Prelude hiding (id,(.))

newtype CoStateArrow s a b c = CoStateArrow (a (s -> b) (s -> c))

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

instance Arrow a => Arrow (CoStateArrow s a) where
    arr :: (b -> c) -> CoStateArrow s a b c
arr b -> c
f = a (s -> b) (s -> c) -> CoStateArrow s a b c
forall s (a :: * -> * -> *) b c.
a (s -> b) (s -> c) -> CoStateArrow s a b c
CoStateArrow (((s -> b) -> s -> c) -> a (s -> b) (s -> c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (b -> c
f (b -> c) -> (s -> b) -> s -> c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.))
    first :: CoStateArrow s a b c -> CoStateArrow s a (b, d) (c, d)
first (CoStateArrow a (s -> b) (s -> c)
f) =
        a (s -> (b, d)) (s -> (c, d)) -> CoStateArrow s a (b, d) (c, d)
forall s (a :: * -> * -> *) b c.
a (s -> b) (s -> c) -> CoStateArrow s a b c
CoStateArrow (((s -> (b, d)) -> (s -> b, s -> d))
-> a (s -> (b, d)) (s -> b, s -> d)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (s -> (b, d)) -> (s -> b, s -> d)
forall s a b. (s -> (a, b)) -> (s -> a, s -> b)
unzipMap a (s -> (b, d)) (s -> b, s -> d)
-> a (s -> b, s -> d) (s -> (c, d))
-> a (s -> (b, d)) (s -> (c, d))
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a (s -> b) (s -> c) -> a (s -> b, s -> d) (s -> c, s -> d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a (s -> b) (s -> c)
f a (s -> b, s -> d) (s -> c, s -> d)
-> a (s -> c, s -> d) (s -> (c, d))
-> a (s -> b, s -> d) (s -> (c, d))
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((s -> c, s -> d) -> s -> (c, d))
-> a (s -> c, s -> d) (s -> (c, d))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (s -> c, s -> d) -> s -> (c, d)
forall s a b. (s -> a, s -> b) -> s -> (a, b)
zipMap)

zipMap :: (s -> a, s -> b) -> (s -> (a,b))
zipMap :: (s -> a, s -> b) -> s -> (a, b)
zipMap (s -> a, s -> b)
h s
s = ((s -> a, s -> b) -> s -> a
forall a b. (a, b) -> a
fst (s -> a, s -> b)
h s
s, (s -> a, s -> b) -> s -> b
forall a b. (a, b) -> b
snd (s -> a, s -> b)
h s
s)

unzipMap :: (s -> (a,b)) -> (s -> a, s -> b)
unzipMap :: (s -> (a, b)) -> (s -> a, s -> b)
unzipMap s -> (a, b)
h = ((a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a) -> (s -> (a, b)) -> s -> a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. s -> (a, b)
h, (a, b) -> b
forall a b. (a, b) -> b
snd ((a, b) -> b) -> (s -> (a, b)) -> s -> b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. s -> (a, b)
h)

-- there is no transformer

-- promotions of standard classes

instance ArrowLoop a => ArrowLoop (CoStateArrow s a) where
    loop :: CoStateArrow s a (b, d) (c, d) -> CoStateArrow s a b c
loop (CoStateArrow a (s -> (b, d)) (s -> (c, d))
f) =
        a (s -> b) (s -> c) -> CoStateArrow s a b c
forall s (a :: * -> * -> *) b c.
a (s -> b) (s -> c) -> CoStateArrow s a b c
CoStateArrow (a (s -> b, s -> d) (s -> c, s -> d) -> a (s -> b) (s -> c)
forall (a :: * -> * -> *) b d c.
ArrowLoop a =>
a (b, d) (c, d) -> a b c
loop (((s -> b, s -> d) -> s -> (b, d))
-> a (s -> b, s -> d) (s -> (b, d))
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (s -> b, s -> d) -> s -> (b, d)
forall s a b. (s -> a, s -> b) -> s -> (a, b)
zipMap a (s -> b, s -> d) (s -> (b, d))
-> a (s -> (b, d)) (s -> c, s -> d)
-> a (s -> b, s -> 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
>>> a (s -> (b, d)) (s -> (c, d))
f a (s -> (b, d)) (s -> (c, d))
-> a (s -> (c, d)) (s -> c, s -> d)
-> a (s -> (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
>>> ((s -> (c, d)) -> (s -> c, s -> d))
-> a (s -> (c, d)) (s -> c, s -> d)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (s -> (c, d)) -> (s -> c, s -> d)
forall s a b. (s -> (a, b)) -> (s -> a, s -> b)
unzipMap))

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

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

-- Other instances

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

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

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

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