Repository : ssh://darcs.haskell.org//srv/darcs/testsuite On branch : master
https://github.com/ghc/testsuite/commit/e0481fc664c16ba3c118506e153d8b27c3c2c9c8 >--------------------------------------------------------------- commit e0481fc664c16ba3c118506e153d8b27c3c2c9c8 Author: Austin Seipp <ase...@pobox.com> Date: Thu May 30 08:28:11 2013 -0500 Whoops. :( Signed-off-by: Austin Seipp <ase...@pobox.com> >--------------------------------------------------------------- tests/polykinds/CatPairs.hs | 30 ++++++++++++++++++++++++++++++ 1 files changed, 30 insertions(+), 0 deletions(-) diff --git a/tests/polykinds/CatPairs.hs b/tests/polykinds/CatPairs.hs new file mode 100644 index 0000000..8ab709e --- /dev/null +++ b/tests/polykinds/CatPairs.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds #-} +module CatPairs where +import Control.Monad +import Control.Category + +-- Take from Twan van Laarhoven +-- http://twanvl.nl/blog/haskell/categories-over-pairs-of-types + +data Pipe i o u m r = Pipe { runPipe :: Either i u -> m (Either o r) } + +(>+>) :: Monad m + => Pipe io1 io2 ur1 m ur2 + -> Pipe io2 io3 ur2 m ur3 + -> Pipe io1 io3 ur1 m ur3 +(>+>) (Pipe f) (Pipe g) = Pipe (f >=> g) + +idP :: Monad m => Pipe i i r m r +idP = Pipe return + +type family Fst (xy :: (*,*)) :: * +type family Snd (xy :: (*,*)) :: * +type instance Fst '(x,y) = x +type instance Snd '(x,y) = y + +newtype WrapPipe m iu or = WrapPipe + { unWrapPipe :: Pipe (Fst iu) (Fst or) (Snd iu) m (Snd or) } + +instance Monad m => Category (WrapPipe m) where + id = WrapPipe idP + x . y = WrapPipe (unWrapPipe y >+> unWrapPipe x) _______________________________________________ ghc-commits mailing list ghc-commits@haskell.org http://www.haskell.org/mailman/listinfo/ghc-commits
