adapt tests to new Category superclass of Arrow

3 files changed, 26 insertions, 8 deletions

diff --git a/testsuite/tests/ghc-regress/arrows/should_run/arrowrun002.hs b/testsuite/tests/ghc-regress/arrows/should_run/arrowrun002.hs
index 7fdbff08da..b1feeba55f 100644
--- a/testsuite/tests/ghc-regress/arrows/should_run/arrowrun002.hs
+++ b/testsuite/tests/ghc-regress/arrows/should_run/arrowrun002.hs
@@ -5,7 +5,9 @@
 module Main where
 
 import Control.Arrow
+import Control.Category
 import Data.Complex
+import Prelude hiding (id, (.))
 
 infixr 4 :&:
 
@@ -53,9 +55,12 @@ apply (f :&: fs) (Succ t) = Succ (apply fs t)
 -- Having defined apply, we can forget about powertrees and do all our
 -- programming with Hom's.  Firstly, Hom is an arrow:
 
+instance Category Hom where
+	id = id :&: id
+	(f :&: fs) . (g :&: gs) = (f . g) :&: (fs . gs)
+
 instance Arrow Hom where
 	arr f = f :&: arr (f *** f)
-	(f :&: fs) >>> (g :&: gs) = (g . f) :&: (fs >>> gs)
 	first (f :&: fs) =
 		first f :&: (arr transpose >>> first fs >>> arr transpose)
 
diff --git a/testsuite/tests/ghc-regress/arrows/should_run/arrowrun003.hs b/testsuite/tests/ghc-regress/arrows/should_run/arrowrun003.hs
index 72bec6743b..9e568aa6dd 100644
--- a/testsuite/tests/ghc-regress/arrows/should_run/arrowrun003.hs
+++ b/testsuite/tests/ghc-regress/arrows/should_run/arrowrun003.hs
@@ -3,6 +3,8 @@
 module Main(main) where
 
 import Control.Arrow
+import Control.Category
+import Prelude hiding (id, (.))
 
 class ArrowLoop a => ArrowCircuit a where
 	delay :: b -> a b b
@@ -23,9 +25,12 @@ unzipStream abs = (fmap fst abs, fmap snd abs)
 newtype StreamMap a b = StreamMap (Stream a -> Stream b)
 unStreamMap (StreamMap f) = f
 
+instance Category StreamMap where
+	id = StreamMap id
+	StreamMap f . StreamMap g = StreamMap (f . g)
+
 instance Arrow StreamMap where
 	arr f = StreamMap (fmap f)
-	StreamMap f >>> StreamMap g = StreamMap (g . f)
 	first (StreamMap f) =
 		StreamMap (uncurry zipStream . first f . unzipStream)
 
@@ -50,12 +55,15 @@ runStreamMap (StreamMap f) as =
 
 data Auto a b = Auto (a -> (b, Auto a b))
 
+instance Category Auto where
+	id = Auto $ \a -> (a, id)
+	Auto f . Auto g = Auto $ \b ->
+				let	(c, g') = g b
+					(d, f') = f c
+				in	(d, f' . g')
+
 instance Arrow Auto where
 	arr f = Auto $ \a -> (f a, arr f)
-	Auto f >>> Auto g = Auto $ \b ->
-				let	(c, f') = f b
-					(d, g') = g c
-				in	(d, f' >>> g')
 	first (Auto f) = Auto $ \(b,d) -> let (c,f') = f b in ((c,d), first f')
 
 instance ArrowLoop Auto where
diff --git a/testsuite/tests/ghc-regress/arrows/should_run/arrowrun004.hs b/testsuite/tests/ghc-regress/arrows/should_run/arrowrun004.hs
index 3d6a3d5bfd..32002c8797 100644
--- a/testsuite/tests/ghc-regress/arrows/should_run/arrowrun004.hs
+++ b/testsuite/tests/ghc-regress/arrows/should_run/arrowrun004.hs
@@ -6,7 +6,9 @@
 module Main(main) where
 
 import Control.Arrow
+import Control.Category
 import Data.Char
+import Prelude hiding (id, (.))
 
 -- Parsers
 
@@ -19,10 +21,13 @@ data Sym s = Sym { token :: s, value :: String }
 
 newtype BTParser s a b = BTParser (a -> [Sym s] -> [(b, [Sym s])])
 
+instance Category (BTParser s) where
+	id = BTParser $ \a ss -> [(a, ss)]
+	BTParser f . BTParser g = BTParser $ \b ss ->
+		[(d, ss'') | (c, ss') <- g b ss, (d, ss'') <- f c ss']
+
 instance Arrow (BTParser s) where
 	arr f = BTParser $ \a ss -> [(f a, ss)]
-	BTParser f >>> BTParser g = BTParser $ \b ss ->
-		[(d, ss'') | (c, ss') <- f b ss, (d,ss'') <- g c ss']
 	first (BTParser f) = BTParser $ \(b,d) ss ->
 		[((c,d), ss') | (c,ss') <- f b ss]