[commit: testsuite] master: Whoops. :( (e0481fc)

[Austin Seipp]

Repository : ssh://darcs.haskell.org//srv/darcs/testsuite

On branch  : master

https://github.com/ghc/testsuite/commit/e0481fc664c16ba3c118506e153d8b27c3c2c9c8

>---------------------------------------------------------------

commit e0481fc664c16ba3c118506e153d8b27c3c2c9c8
Author: Austin Seipp <aseipp at pobox.com>
Date:   Thu May 30 08:28:11 2013 -0500

    Whoops. :(
    
    Signed-off-by: Austin Seipp <aseipp at 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)