> {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}

> module Control.Arrow.ArrowP where

> import Control.Arrow
> import Control.Arrow.Operations
#if __GLASGOW_HASKELL__ >= 610
> import Control.Category
> import Prelude hiding ((.), id)
#endif

> newtype ArrowP a p b c = ArrowP { forall (a :: * -> * -> *) p b c. ArrowP a p b c -> a b c
strip :: a b c }

#if __GLASGOW_HASKELL__ >= 610
> instance Category a => Category (ArrowP a p) where
>   id :: forall a. ArrowP a p a a
id = a a a -> ArrowP a p a a
forall (a :: * -> * -> *) p b c. a b c -> ArrowP a p b c
ArrowP a a a
forall a. a a a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
>   ArrowP a b c
g . :: forall b c a. ArrowP a p b c -> ArrowP a p a b -> ArrowP a p a c
. ArrowP a a b
f = a a c -> ArrowP a p a c
forall (a :: * -> * -> *) p b c. a b c -> ArrowP a p b c
ArrowP (a b c
g a b c -> a a b -> a a c
forall b c a. a b c -> a a b -> a a 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 b
f)

> instance Arrow a => Arrow (ArrowP a p) where
>   arr :: forall b c. (b -> c) -> ArrowP a p b c
arr b -> c
f = a b c -> ArrowP a p b c
forall (a :: * -> * -> *) p b c. a b c -> ArrowP a p b c
ArrowP ((b -> c) -> a b c
forall b c. (b -> c) -> a b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> c
f)
>   first :: forall b c d. ArrowP a p b c -> ArrowP a p (b, d) (c, d)
first (ArrowP a b c
f) = a (b, d) (c, d) -> ArrowP a p (b, d) (c, d)
forall (a :: * -> * -> *) p b c. a b c -> ArrowP a p b c
ArrowP (a b c -> a (b, d) (c, d)
forall b c d. a b c -> a (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a b c
f)
#else
> instance Arrow a => Arrow (ArrowP a p) where
>   arr f = ArrowP (arr f)
>   first (ArrowP f) = ArrowP (first f)
>   ArrowP f >>> ArrowP g = ArrowP (f >>> g)
#endif

> instance ArrowLoop a => ArrowLoop (ArrowP a p) where
>   loop :: forall b d c. ArrowP a p (b, d) (c, d) -> ArrowP a p b c
loop (ArrowP a (b, d) (c, d)
f) = a b c -> ArrowP a p b c
forall (a :: * -> * -> *) p b c. a b c -> ArrowP a p b c
ArrowP (a (b, d) (c, d) -> a b c
forall b d c. a (b, d) (c, d) -> a b c
forall (a :: * -> * -> *) b d c.
ArrowLoop a =>
a (b, d) (c, d) -> a b c
loop a (b, d) (c, d)
f)

> instance ArrowCircuit a => ArrowCircuit (ArrowP a p) where
>   delay :: forall b. b -> ArrowP a p b b
delay b
i = a b b -> ArrowP a p b b
forall (a :: * -> * -> *) p b c. a b c -> ArrowP a p b c
ArrowP (b -> a b b
forall b. b -> a b b
forall (a :: * -> * -> *) b. ArrowCircuit a => b -> a b b
delay b
i)

> instance ArrowChoice a => ArrowChoice (ArrowP a p) where
>   left :: forall b c d.
ArrowP a p b c -> ArrowP a p (Either b d) (Either c d)
left (ArrowP a b c
f) = a (Either b d) (Either c d) -> ArrowP a p (Either b d) (Either c d)
forall (a :: * -> * -> *) p b c. a b c -> ArrowP a p b c
ArrowP (a b c -> a (Either b d) (Either c d)
forall b c d. a b c -> a (Either b d) (Either c d)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left a b c
f)
>   ArrowP a b d
f ||| :: forall b d c.
ArrowP a p b d -> ArrowP a p c d -> ArrowP a p (Either b c) d
||| ArrowP a c d
g = a (Either b c) d -> ArrowP a p (Either b c) d
forall (a :: * -> * -> *) p b c. a b c -> ArrowP a p b c
ArrowP (a b d
f a b d -> a c d -> a (Either b c) d
forall b d c. a b d -> a c d -> a (Either b c) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| a c d
g)