[commit: base] master: Add tests for kind-polymorphic Control.Category (d901b4c)

[Austin Seipp]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/base

On branch  : master

https://github.com/ghc/packages-base/commit/d901b4c738685f72bd9bfd48bfe292e7134325bd

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

commit d901b4c738685f72bd9bfd48bfe292e7134325bd
Author: Austin Seipp <aseipp at pobox.com>
Date:   Fri May 31 12:17:46 2013 -0500

    Add tests for kind-polymorphic Control.Category
    
    Signed-off-by: Austin Seipp <aseipp at pobox.com>

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

 tests/CatEntail.hs |   27 +++++++++++++++++++++++++++
 tests/CatPairs.hs  |   34 ++++++++++++++++++++++++++++++++++
 tests/all.T        |    4 ++++
 3 files changed, 65 insertions(+), 0 deletions(-)

diff --git a/tests/CatEntail.hs b/tests/CatEntail.hs
new file mode 100644
index 0000000..bc2d8d2
--- /dev/null
+++ b/tests/CatEntail.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes #-}
+{-# LANGUAGE TypeOperators, KindSignatures #-}
+module CatEntail where
+import Prelude hiding (id, (.))
+import GHC.Prim (Constraint)
+import Control.Category
+
+-- One dictionary to rule them all.
+data Dict :: Constraint -> * where
+  Dict :: ctx => Dict ctx
+
+-- Entailment.
+-- Note the kind 'Constraint -> Constraint -> *'
+newtype (|-) a b = Sub (a => Dict b)
+
+(\\) :: a => (b => r) -> (a |- b) -> r
+r \\ Sub Dict = r
+
+reflexive :: a |- a
+reflexive = Sub Dict
+
+transitive :: (b |- c) -> (a |- b) -> a |- c
+transitive f g = Sub $ Dict \\ f \\ g
+
+instance Category (|-) where
+  id  = reflexive
+  (.) = transitive
diff --git a/tests/CatPairs.hs b/tests/CatPairs.hs
new file mode 100644
index 0000000..6efa9cc
--- /dev/null
+++ b/tests/CatPairs.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE PolyKinds, DataKinds, KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
+module CatPairs where
+import Prelude hiding (id, (.))
+import Control.Monad ((>=>))
+import Control.Category
+
+-- Categories over pairs of types.
+-- Taken from Twan van Laarhoven:
+--   http://twanvl.nl/blog/haskell/categories-over-pairs-of-types
+
+type family Fst (xy :: (*,*)) :: *
+type family Snd (xy :: (*,*)) :: *
+type instance Fst '(x,y) = x
+type instance Snd '(x,y) = y
+
+-- Ceci n'est pas une pipe
+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
+
+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)
diff --git a/tests/all.T b/tests/all.T
index 5d0dd24..b9e9eb8 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -125,3 +125,7 @@ test('T7457', normal, compile_and_run, [''])
 
 test('T7773', when(opsys('mingw32'), skip), compile_and_run, [''])
 # Andreas says that T7773 will not (and should not) work on Windows
+
+# Tests for kind-polymorphic Category
+test('CatPairs', normal, compile, [''])
+test('CatEntail', normal, compile, [''])