Add tests for kind-polymorphic Control.Category
authorAustin Seipp <aseipp@pobox.com>
Fri, 31 May 2013 17:17:46 +0000 (12:17 -0500)
committerAustin Seipp <aseipp@pobox.com>
Fri, 31 May 2013 18:01:40 +0000 (13:01 -0500)
Signed-off-by: Austin Seipp <aseipp@pobox.com>
tests/CatEntail.hs [new file with mode: 0644]
tests/CatPairs.hs [new file with mode: 0644]
tests/all.T

diff --git a/tests/CatEntail.hs b/tests/CatEntail.hs
new file mode 100644 (file)
index 0000000..bc2d8d2
--- /dev/null
@@ -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 (file)
index 0000000..6efa9cc
--- /dev/null
@@ -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)
index 5d0dd24..b9e9eb8 100644 (file)
@@ -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, [''])