> {-# 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)