Move tests from tests/ghc-regress/* to just tests/*

44 files changed, 1165 insertions, 0 deletions

diff --git a/testsuite/tests/arrows/Makefile b/testsuite/tests/arrows/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/arrows/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/arrows/should_compile/Makefile b/testsuite/tests/arrows/should_compile/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/arrows/should_compile/T3964.hs b/testsuite/tests/arrows/should_compile/T3964.hs
new file mode 100644
index 0000000000..713c7e2303
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/T3964.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE Arrows, ViewPatterns #-}
+
+module T3964 where
+
+import Control.Arrow
+
+testF :: Eq a => a -> (Maybe (Maybe a)) -> Maybe a
+testF v = proc x -> case x of
+     Just (Just ((==v) -> True)) -> returnA -< Just v
+     _                           -> returnA -< Nothing
diff --git a/testsuite/tests/arrows/should_compile/T5283.hs b/testsuite/tests/arrows/should_compile/T5283.hs
new file mode 100644
index 0000000000..9216d3cd67
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/T5283.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE Arrows #-}
+-- Failed in ghci
+
+module T where
+
+import Prelude
+import Control.Arrow
+
+mapAC :: Arrow arr => Integer -> arr (env, b) c -> arr (env, [b]) [c]  
+mapAC n farr = go 1
+  where
+    go i | i == succ n = arr (\(_env, []) -> [])
+         | otherwise = proc ~(env, b : bs) ->
+             do c  <- farr -< (env, b)
+                cs <- go (succ i) -< (env, bs)
+                returnA -< c : cs
+
+t :: Arrow arr => arr [a] [a]
+t = proc ys ->
+     (| (mapAC 3) (\y -> returnA -< y) |) ys
diff --git a/testsuite/tests/arrows/should_compile/all.T b/testsuite/tests/arrows/should_compile/all.T
new file mode 100644
index 0000000000..3351b9f4ba
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/all.T
@@ -0,0 +1,18 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('arrowapply1', normal, compile, [''])
+test('arrowapply2', normal, compile, [''])
+test('arrowapply3', normal, compile, [''])
+test('arrowapply4', normal, compile, [''])
+test('arrowapply5', normal, compile, [''])
+test('arrowcase1', normal, compile, [''])
+test('arrowdo1', normal, compile, [''])
+test('arrowdo2', normal, compile, [''])
+# test('arrowdo3', normal, compile, [''])	# takes too long
+test('arrowform1', normal, compile, [''])
+test('arrowif1', normal, compile, [''])
+test('arrowlet1', normal, compile, [''])
+test('arrowrec1', normal, compile, [''])
+test('arrowpat', normal, compile, [''])
+test('T3964', normal, compile, [''])
+test('T5283', normal, compile, [''])
diff --git a/testsuite/tests/arrows/should_compile/arrowapply1.hs b/testsuite/tests/arrows/should_compile/arrowapply1.hs
new file mode 100644
index 0000000000..abad47de26
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowapply1.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+import Control.Arrow
+
+f :: Arrow a => a (Int,Int,Int) Int
+f = proc (x,y,z) -> returnA -< x+y
diff --git a/testsuite/tests/arrows/should_compile/arrowapply2.hs b/testsuite/tests/arrows/should_compile/arrowapply2.hs
new file mode 100644
index 0000000000..16cf2f3039
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowapply2.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+import Control.Arrow
+
+f :: ArrowApply a => a (a Int Int,Int,Int) Int
+f = proc (x,y,z) -> x -<< 2+y
+
+g :: ArrowApply a => Int -> a (a Int Int,Int) Int
+g y = proc (x,z) -> x -<< 2+y
diff --git a/testsuite/tests/arrows/should_compile/arrowapply3.hs b/testsuite/tests/arrows/should_compile/arrowapply3.hs
new file mode 100644
index 0000000000..3a9b49da92
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowapply3.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+import Control.Arrow
+
+g :: Arrow a => a Int c -> a Int c
+g f = proc b -> f -< b+2
diff --git a/testsuite/tests/arrows/should_compile/arrowapply4.hs b/testsuite/tests/arrows/should_compile/arrowapply4.hs
new file mode 100644
index 0000000000..af0dac4cee
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowapply4.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+-- example from Sebastian Boldt <Sebastian.Boldt@arcor.de>:
+--	(f -< a) b  ===  f -< (a,b)
+
+import Control.Arrow
+
+mshowA :: (Arrow a, Show b) => a (b, String) String
+mshowA = proc (x,s) -> returnA -< s ++ show x ++ s
+
+f :: Arrow a => a Int String
+f = proc x -> (mshowA -< x) "***"
+
+g :: ArrowApply a => a Int String
+g = proc x -> (mshowA -<< x) "***"
diff --git a/testsuite/tests/arrows/should_compile/arrowapply5.hs b/testsuite/tests/arrows/should_compile/arrowapply5.hs
new file mode 100644
index 0000000000..46d1dc587f
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowapply5.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+-- variables bound inside the left argument of -< should be in scope
+
+import Control.Arrow
+
+f :: (Num b, Arrow a) => a b b
+f = proc x -> arr (\y -> y-1) -< x
+
+g :: (Num b, Arrow a) => a b b
+g = proc x -> (proc y -> returnA -< y-1) -< x
diff --git a/testsuite/tests/arrows/should_compile/arrowcase1.hs b/testsuite/tests/arrows/should_compile/arrowcase1.hs
new file mode 100644
index 0000000000..6d39b0be73
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowcase1.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+import Control.Arrow
+
+h :: ArrowChoice a => Int -> a (Int,Int) Int
+h x = proc (y,z) -> case compare x y of
+	LT -> returnA -< x
+	EQ -> returnA -< y+z
+	GT -> returnA -< z+x
+
+g :: ArrowChoice a => Int -> a (Int,Int) Int
+g x = proc (y,z) -> (case compare x y of
+	LT -> \ a -> returnA -< x+a
+	EQ -> \ b -> returnA -< y+z+b
+	GT -> \ c -> returnA -< z+x
+    ) 1
diff --git a/testsuite/tests/arrows/should_compile/arrowdo1.hs b/testsuite/tests/arrows/should_compile/arrowdo1.hs
new file mode 100644
index 0000000000..b70eedd460
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowdo1.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+import Control.Arrow
+
+f :: Arrow a => a (Int,Int,Int) Int
+f = proc (x,y,z) -> returnA -< x+y
+
+g :: Arrow a => Int -> a Int Int
+g x = proc y -> returnA -< x*y
+
+h :: Arrow a => Int -> a (Int,Int) Int
+h x = proc (y,z) -> do
+	a <- f -< (x,y,3)
+	b <- g (2+x) -< y+a
+	returnA -< a*b+z
diff --git a/testsuite/tests/arrows/should_compile/arrowdo2.hs b/testsuite/tests/arrows/should_compile/arrowdo2.hs
new file mode 100644
index 0000000000..3562dc23b9
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowdo2.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+import Control.Arrow
+
+f :: Arrow a => a (Int,Int) Int
+f = proc (x,y) -> do
+	let z = x*y
+	returnA -< y+z
diff --git a/testsuite/tests/arrows/should_compile/arrowdo3.hs b/testsuite/tests/arrows/should_compile/arrowdo3.hs
new file mode 100644
index 0000000000..3b6a8c8d35
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowdo3.hs
@@ -0,0 +1,222 @@
+{-# LANGUAGE Arrows #-}
+
+-- test for out-size tuples: takes a _long_ time to compile
+
+module ShouldCompile where
+
+import Control.Arrow
+
+data T1 = C1
+data T2 = C2
+data T3 = C3
+data T4 = C4
+data T5 = C5
+data T6 = C6
+data T7 = C7
+data T8 = C8
+data T9 = C9
+data T10 = C10
+data T11 = C11
+data T12 = C12
+data T13 = C13
+data T14 = C14
+data T15 = C15
+data T16 = C16
+data T17 = C17
+data T18 = C18
+data T19 = C19
+data T20 = C20
+data T21 = C21
+data T22 = C22
+data T23 = C23
+data T24 = C24
+data T25 = C25
+data T26 = C26
+data T27 = C27
+data T28 = C28
+data T29 = C29
+data T30 = C30
+data T31 = C31
+data T32 = C32
+data T33 = C33
+data T34 = C34
+data T35 = C35
+data T36 = C36
+data T37 = C37
+data T38 = C38
+data T39 = C39
+data T40 = C40
+data T41 = C41
+data T42 = C42
+data T43 = C43
+data T44 = C44
+data T45 = C45
+data T46 = C46
+data T47 = C47
+data T48 = C48
+data T49 = C49
+data T50 = C50
+data T51 = C51
+data T52 = C52
+data T53 = C53
+data T54 = C54
+data T55 = C55
+data T56 = C56
+data T57 = C57
+data T58 = C58
+data T59 = C59
+data T60 = C60
+data T61 = C61
+data T62 = C62
+data T63 = C63
+data T64 = C64
+data T65 = C65
+data T66 = C66
+data T67 = C67
+data T68 = C68
+data T69 = C69
+data T70 = C70
+
+f :: Arrow a => a Int Int
+f = proc x0 -> do
+	x1 <- returnA -< C1
+	x2 <- returnA -< C2
+	x3 <- returnA -< C3
+	x4 <- returnA -< C4
+	x5 <- returnA -< C5
+	x6 <- returnA -< C6
+	x7 <- returnA -< C7
+	x8 <- returnA -< C8
+	x9 <- returnA -< C9
+	x10 <- returnA -< C10
+	x11 <- returnA -< C11
+	x12 <- returnA -< C12
+	x13 <- returnA -< C13
+	x14 <- returnA -< C14
+	x15 <- returnA -< C15
+	x16 <- returnA -< C16
+	x17 <- returnA -< C17
+	x18 <- returnA -< C18
+	x19 <- returnA -< C19
+	x20 <- returnA -< C20
+	x21 <- returnA -< C21
+	x22 <- returnA -< C22
+	x23 <- returnA -< C23
+	x24 <- returnA -< C24
+	x25 <- returnA -< C25
+	x26 <- returnA -< C26
+	x27 <- returnA -< C27
+	x28 <- returnA -< C28
+	x29 <- returnA -< C29
+	x30 <- returnA -< C30
+	x31 <- returnA -< C31
+	x32 <- returnA -< C32
+	x33 <- returnA -< C33
+	x34 <- returnA -< C34
+	x35 <- returnA -< C35
+	x36 <- returnA -< C36
+	x37 <- returnA -< C37
+	x38 <- returnA -< C38
+	x39 <- returnA -< C39
+	x40 <- returnA -< C40
+	x41 <- returnA -< C41
+	x42 <- returnA -< C42
+	x43 <- returnA -< C43
+	x44 <- returnA -< C44
+	x45 <- returnA -< C45
+	x46 <- returnA -< C46
+	x47 <- returnA -< C47
+	x48 <- returnA -< C48
+	x49 <- returnA -< C49
+	x50 <- returnA -< C50
+	x51 <- returnA -< C51
+	x52 <- returnA -< C52
+	x53 <- returnA -< C53
+	x54 <- returnA -< C54
+	x55 <- returnA -< C55
+	x56 <- returnA -< C56
+	x57 <- returnA -< C57
+	x58 <- returnA -< C58
+	x59 <- returnA -< C59
+	x60 <- returnA -< C60
+	x61 <- returnA -< C61
+	x62 <- returnA -< C62
+	x63 <- returnA -< C63
+	x64 <- returnA -< C64
+	x65 <- returnA -< C65
+	x66 <- returnA -< C66
+	x67 <- returnA -< C67
+	x68 <- returnA -< C68
+	x69 <- returnA -< C69
+	x70 <- returnA -< C70
+	returnA -< x70
+	returnA -< x69
+	returnA -< x68
+	returnA -< x67
+	returnA -< x66
+	returnA -< x65
+	returnA -< x64
+	returnA -< x63
+	returnA -< x62
+	returnA -< x61
+	returnA -< x60
+	returnA -< x59
+	returnA -< x58
+	returnA -< x57
+	returnA -< x56
+	returnA -< x55
+	returnA -< x54
+	returnA -< x53
+	returnA -< x52
+	returnA -< x51
+	returnA -< x50
+	returnA -< x49
+	returnA -< x48
+	returnA -< x47
+	returnA -< x46
+	returnA -< x45
+	returnA -< x44
+	returnA -< x43
+	returnA -< x42
+	returnA -< x41
+	returnA -< x40
+	returnA -< x39
+	returnA -< x38
+	returnA -< x37
+	returnA -< x36
+	returnA -< x35
+	returnA -< x34
+	returnA -< x33
+	returnA -< x32
+	returnA -< x31
+	returnA -< x30
+	returnA -< x29
+	returnA -< x28
+	returnA -< x27
+	returnA -< x26
+	returnA -< x25
+	returnA -< x24
+	returnA -< x23
+	returnA -< x22
+	returnA -< x21
+	returnA -< x20
+	returnA -< x19
+	returnA -< x18
+	returnA -< x17
+	returnA -< x16
+	returnA -< x15
+	returnA -< x14
+	returnA -< x13
+	returnA -< x12
+	returnA -< x11
+	returnA -< x10
+	returnA -< x9
+	returnA -< x8
+	returnA -< x7
+	returnA -< x6
+	returnA -< x5
+	returnA -< x4
+	returnA -< x3
+	returnA -< x2
+	returnA -< x1
+	returnA -< x0
diff --git a/testsuite/tests/arrows/should_compile/arrowform1.hs b/testsuite/tests/arrows/should_compile/arrowform1.hs
new file mode 100644
index 0000000000..a282d71ed7
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowform1.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+import Control.Arrow
+
+handle :: ArrowPlus a => a b c -> a (b,String) c -> a b c
+handle f h = proc b -> (f -< b) <+> (h -< (b,""))
+
+f :: ArrowPlus a => a (Int,Int) String
+f = proc (x,y) ->
+	(|handle
+		(returnA -< show y)
+		(\s -> returnA -< s ++ show x)
+	|)
+
+g :: ArrowPlus a => a (Int,Int) String
+g = proc (x,y) ->
+	(|handle
+		(\msg -> returnA -< msg ++ show y)
+		(\s msg -> returnA -< s ++ show x)
+	|) ("hello " ++ show x)
+
+h :: ArrowPlus a => a (Int,Int) Int
+h = proc (x,y) ->
+	(
+		(\z -> returnA -< x + z)
+		<+>
+		(\z -> returnA -< y + z)
+	) (x*y)
diff --git a/testsuite/tests/arrows/should_compile/arrowif1.hs b/testsuite/tests/arrows/should_compile/arrowif1.hs
new file mode 100644
index 0000000000..404b1f164c
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowif1.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+import Control.Arrow
+
+f :: ArrowChoice a => a (Int,Int,Int) Int
+f = proc (x,y,z) -> if x < y then returnA -< x+y else returnA -< x+z
+
+g :: ArrowChoice a => Int -> a (Int,Int) Int
+g x = proc (y,z) -> if x < y then returnA -< x+y else returnA -< x+z
diff --git a/testsuite/tests/arrows/should_compile/arrowlet1.hs b/testsuite/tests/arrows/should_compile/arrowlet1.hs
new file mode 100644
index 0000000000..b08e030d1c
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowlet1.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+import Control.Arrow
+
+f :: Arrow a => a (Int,Int) Int
+f = proc (x,y) -> let z = x*y in returnA -< y+z
diff --git a/testsuite/tests/arrows/should_compile/arrowpat.hs b/testsuite/tests/arrows/should_compile/arrowpat.hs
new file mode 100644
index 0000000000..56b1117e9a
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowpat.hs
@@ -0,0 +1,23 @@
+{-# OPTIONS -XArrows #-}
+
+-- Test for Trac #1662
+
+module Arrow where
+
+import Control.Arrow
+
+expr' :: Arrow a => a Int Int
+expr' = error "urk"
+
+term :: Arrow a => a () Int
+term = error "urk"
+
+expr1 :: Arrow a => a () Int
+expr1 = proc () -> do
+          x <- term -< ()
+          expr' -< x
+
+expr2 :: Arrow a => a () Int
+expr2 = proc y -> do
+          x <- term -< y
+          expr' -< x
diff --git a/testsuite/tests/arrows/should_compile/arrowrec1.hs b/testsuite/tests/arrows/should_compile/arrowrec1.hs
new file mode 100644
index 0000000000..57b6de783c
--- /dev/null
+++ b/testsuite/tests/arrows/should_compile/arrowrec1.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldCompile where
+
+import Control.Arrow
+import Data.Char
+
+f :: ArrowLoop a => a Char Int
+f = proc x -> do
+	a <- returnA -< ord x
+	rec	b <- returnA -< ord c - ord x
+		c <- returnA -< chr a
+	returnA -< b + ord c
diff --git a/testsuite/tests/arrows/should_fail/Makefile b/testsuite/tests/arrows/should_fail/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/arrows/should_fail/T2111.hs b/testsuite/tests/arrows/should_fail/T2111.hs
new file mode 100644
index 0000000000..eb242cdd6b
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/T2111.hs
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -XArrows -XDoRec -XRecursiveDo#-}
+-- Test Trac #2111
+
+module Foo where
+
+foo = do { rec { x <- undefined -< x }; undefined -< x }
+
+bar1 = do { rec { x <- return ('a':x); }; putStrLn (take 20 x) }
+
+bar2 = mdo { rec { x <- return ('a':x); }; putStrLn (take 20 x) }
diff --git a/testsuite/tests/arrows/should_fail/T2111.stderr b/testsuite/tests/arrows/should_fail/T2111.stderr
new file mode 100644
index 0000000000..9c6c17fb53
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/T2111.stderr
@@ -0,0 +1,13 @@
+
+T2111.hs:1:16:
+    Warning: -XRecursiveDo is deprecated: use -XDoRec or pragma {-# LANGUAGE DoRec #-} instead
+
+T2111.hs:6:23:
+    The arrow command
+      undefined -< x
+    was found where an expression was expected
+    In a stmt of a 'do' block: x <- undefined -< x
+    In a stmt of a 'do' block: rec {x <- undefined -< x}
+    In the expression:
+      do { rec {x <- undefined -< x};
+           undefined -< x }
diff --git a/testsuite/tests/arrows/should_fail/T2111.stderr-ghc-7.0 b/testsuite/tests/arrows/should_fail/T2111.stderr-ghc-7.0
new file mode 100644
index 0000000000..79eb1daaee
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/T2111.stderr-ghc-7.0
@@ -0,0 +1,10 @@
+
+T2111.hs:6:23:
+    The arrow command
+      undefined -< x
+    was found where an expression was expected
+    In a stmt of a 'do' expression: x <- undefined -< x
+    In a stmt of a 'do' expression: rec {x <- undefined -< x}
+    In the expression:
+      do { rec {x <- undefined -< x};
+           undefined -< x }
diff --git a/testsuite/tests/arrows/should_fail/all.T b/testsuite/tests/arrows/should_fail/all.T
new file mode 100644
index 0000000000..4da90faba3
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/all.T
@@ -0,0 +1,7 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('arrowfail001', normal, compile_fail, [''])
+test('arrowfail002', normal, compile_fail, [''])
+test('arrowfail003', normal, compile_fail, [''])
+test('arrowfail004', normal, compile_fail, [''])
+test('T2111', normal, compile_fail, [''])
diff --git a/testsuite/tests/arrows/should_fail/arrowfail001.hs b/testsuite/tests/arrows/should_fail/arrowfail001.hs
new file mode 100644
index 0000000000..e106c214aa
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/arrowfail001.hs
@@ -0,0 +1,21 @@
+
+{-# LANGUAGE Arrows, ExistentialQuantification #-}
+
+-- Crashed GHC 6.4 with a lint error
+-- because of the existential
+
+-- Esa Pulkkinen <esa.pulkkinen@kotiposti.net>
+-- Thomas Jäger <ThJaeger@gmail.com>
+
+module ShouldFail where
+
+class Foo a where foo :: a -> ()
+data Bar = forall a. Foo a => Bar a
+
+get :: Bar -> ()
+get = proc x -> case x of Bar a -> foo -< a
+
+-- This should be rejected because the left side of -< (here foo)
+-- should be treated as being outside the scope of the proc: it can't
+-- refer to the local variables x and a (this is enforced), nor the
+-- existentially quantified type variable introduced by unwrapping x.
diff --git a/testsuite/tests/arrows/should_fail/arrowfail001.stderr b/testsuite/tests/arrows/should_fail/arrowfail001.stderr
new file mode 100644
index 0000000000..91ec965715
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/arrowfail001.stderr
@@ -0,0 +1,9 @@
+
+arrowfail001.hs:16:36:
+    Ambiguous type variable `a' in the constraint:
+      (Foo a) arising from a use of `foo'
+    Probable fix: add a type signature that fixes these type variable(s)
+    In the expression: foo
+    In the expression: proc x -> case x of { Bar a -> foo -< a }
+    In an equation for `get':
+        get = proc x -> case x of { Bar a -> foo -< a }
diff --git a/testsuite/tests/arrows/should_fail/arrowfail002.hs b/testsuite/tests/arrows/should_fail/arrowfail002.hs
new file mode 100644
index 0000000000..96cc930565
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/arrowfail002.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE Arrows #-}
+
+module ShouldFail where
+
+g :: Int -> Int
+g = proc x -> f x -< x+1
+  where f = (*)
diff --git a/testsuite/tests/arrows/should_fail/arrowfail002.stderr b/testsuite/tests/arrows/should_fail/arrowfail002.stderr
new file mode 100644
index 0000000000..c653acc339
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/arrowfail002.stderr
@@ -0,0 +1,2 @@
+
+arrowfail002.hs:6:17: Not in scope: `x'
diff --git a/testsuite/tests/arrows/should_fail/arrowfail003.hs b/testsuite/tests/arrows/should_fail/arrowfail003.hs
new file mode 100644
index 0000000000..2f8cfeeaed
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/arrowfail003.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE Arrows #-}
+-- Arrow commands where an expression is expected
+
+module ShouldFail where
+
+import Control.Arrow
+
+foo = returnA -< []
+bar = (|zeroArrow|)
diff --git a/testsuite/tests/arrows/should_fail/arrowfail003.stderr b/testsuite/tests/arrows/should_fail/arrowfail003.stderr
new file mode 100644
index 0000000000..39a6b48139
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/arrowfail003.stderr
@@ -0,0 +1,14 @@
+
+arrowfail003.hs:8:7:
+    The arrow command
+      returnA -< []
+    was found where an expression was expected
+    In the expression: returnA -< []
+    In an equation for `foo': foo = returnA -< []
+
+arrowfail003.hs:9:7:
+    The arrow command
+      (|zeroArrow |)
+    was found where an expression was expected
+    In the expression: (|zeroArrow |)
+    In an equation for `bar': bar = (|zeroArrow |)
diff --git a/testsuite/tests/arrows/should_fail/arrowfail004.hs b/testsuite/tests/arrows/should_fail/arrowfail004.hs
new file mode 100644
index 0000000000..3e0835a0e4
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/arrowfail004.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE Arrows, ExistentialQuantification #-}
+
+-- Trac #1662
+
+module ShouldFail where
+
+import Control.Arrow
+
+data T = forall a. T a
+
+panic :: (Arrow arrow) => arrow T T
+panic = proc (T x) -> do returnA -< T x
\ No newline at end of file
diff --git a/testsuite/tests/arrows/should_fail/arrowfail004.stderr b/testsuite/tests/arrows/should_fail/arrowfail004.stderr
new file mode 100644
index 0000000000..8a20c6bcbb
--- /dev/null
+++ b/testsuite/tests/arrows/should_fail/arrowfail004.stderr
@@ -0,0 +1,7 @@
+
+arrowfail004.hs:12:15:
+    Proc patterns cannot use existential or GADT data constructors
+    In the pattern: T x
+    In the expression: proc (T x) -> do { returnA -< T x }
+    In an equation for `panic':
+        panic = proc (T x) -> do { returnA -< T x }
diff --git a/testsuite/tests/arrows/should_run/Makefile b/testsuite/tests/arrows/should_run/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/arrows/should_run/T3822.hs b/testsuite/tests/arrows/should_run/T3822.hs
new file mode 100644
index 0000000000..93e6dc5797
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/T3822.hs
@@ -0,0 +1,17 @@
+
+{-# LANGUAGE Arrows #-}
+
+import Control.Arrow
+import qualified Control.Category as Cat
+
+test :: Int -> Int
+test = proc x -> do
+    let neg = x < 0
+    case x of
+        x | neg -> returnA -< 0           -- GHC panics
+        --x | x < 0 -> returnA -< 0       -- GHC doesn't panic
+        _       -> returnA -< 10
+
+main = do
+    print $ test (-1)
+    print $ test 1
diff --git a/testsuite/tests/arrows/should_run/T3822.stdout b/testsuite/tests/arrows/should_run/T3822.stdout
new file mode 100644
index 0000000000..25e7f55667
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/T3822.stdout
@@ -0,0 +1,2 @@
+0
+10
diff --git a/testsuite/tests/arrows/should_run/all.T b/testsuite/tests/arrows/should_run/all.T
new file mode 100644
index 0000000000..a9867dd395
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/all.T
@@ -0,0 +1,8 @@
+setTestOpts(only_compiler_types(['ghc']))
+
+test('arrowrun001', normal, compile_and_run, [''])
+test('arrowrun002', skip_if_fast, compile_and_run, [''])
+test('arrowrun003', normal, compile_and_run, [''])
+test('arrowrun004', skip_if_fast, compile_and_run, [''])
+test('T3822', normal, compile_and_run, [''])
+
diff --git a/testsuite/tests/arrows/should_run/arrowrun001.hs b/testsuite/tests/arrows/should_run/arrowrun001.hs
new file mode 100644
index 0000000000..c686b32546
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/arrowrun001.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE Arrows #-}
+
+-- Toy lambda-calculus interpreter from John Hughes's arrows paper (s5)
+
+module Main(main) where
+
+import Data.Maybe(fromJust)
+import Control.Arrow
+
+type Id = String
+data Val a = Num Int | Bl Bool | Fun (a (Val a) (Val a))
+data Exp = Var Id | Add Exp Exp | If Exp Exp Exp | Lam Id Exp | App Exp Exp
+
+eval :: (ArrowChoice a, ArrowApply a) => Exp -> a [(Id, Val a)] (Val a)
+eval (Var s) = proc env ->
+		returnA -< fromJust (lookup s env)
+eval (Add e1 e2) = proc env -> do
+		~(Num u) <- eval e1 -< env
+		~(Num v) <- eval e2 -< env
+		returnA -< Num (u + v)
+eval (If e1 e2 e3) = proc env -> do
+		~(Bl b) <- eval e1 -< env
+		if b	then eval e2 -< env
+			else eval e3 -< env
+eval (Lam x e) = proc env ->
+		returnA -< Fun (proc v -> eval e -< (x,v):env)
+eval (App e1 e2) = proc env -> do
+		~(Fun f) <- eval e1 -< env
+		v <- eval e2 -< env
+		f -<< v
+
+-- some tests
+
+i = Lam "x" (Var "x")
+k = Lam "x" (Lam "y" (Var "x"))
+double = Lam "x" (Add (Var "x") (Var "x"))
+
+-- if b then k (double x) x else x + x + x
+
+text_exp = If (Var "b")
+		(App (App k (App double (Var "x"))) (Var "x"))
+		(Add (Var "x") (Add (Var "x") (Var "x")))
+
+unNum (Num n) = n
+
+main = do
+	print (unNum (eval text_exp [("b", Bl True), ("x", Num 5)]))
+	print (unNum (eval text_exp [("b", Bl False), ("x", Num 5)]))
diff --git a/testsuite/tests/arrows/should_run/arrowrun001.stdout b/testsuite/tests/arrows/should_run/arrowrun001.stdout
new file mode 100644
index 0000000000..349103a876
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/arrowrun001.stdout
@@ -0,0 +1,2 @@
+10
+15
diff --git a/testsuite/tests/arrows/should_run/arrowrun002.hs b/testsuite/tests/arrows/should_run/arrowrun002.hs
new file mode 100644
index 0000000000..16f29806ac
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/arrowrun002.hs
@@ -0,0 +1,225 @@
+{-# LANGUAGE Arrows #-}
+
+-- Homogeneous (or depth-preserving) functions over perfectly balanced trees.
+
+module Main where
+
+import Control.Arrow
+import Control.Category
+import Data.Complex
+import Prelude hiding (id, (.))
+
+infixr 4 :&:
+
+-- Consider the following non-regular type of perfectly balanced trees,
+-- or `powertrees' (cf Jayadev Misra's powerlists):
+
+data Pow a = Zero a | Succ (Pow (Pair a))
+	deriving Show
+
+type Pair a = (a, a)
+
+-- Here are some example elements:
+
+tree0 = Zero 1
+tree1 = Succ (Zero (1, 2))
+tree2 = Succ (Succ (Zero ((1, 2), (3, 4))))
+tree3 = Succ (Succ (Succ (Zero (((1, 2), (3, 4)), ((5, 6), (7, 8))))))
+
+-- The elements of this type have a string of constructors expressing
+-- a depth n as a Peano numeral, enclosing a nested pair tree of 2^n
+-- elements.  The type definition ensures that all elements of this type
+-- are perfectly balanced binary trees of this form.  (Such things arise
+-- in circuit design, eg Ruby, and descriptions of parallel algorithms.)
+-- And the type system will ensure that all legal programs preserve
+-- this structural invariant.
+--  
+-- The only problem is that the type constraint is too restrictive, rejecting
+-- many of the standard operations on these trees.  Typically you want to
+-- split a tree into two subtrees, do some processing on the subtrees and
+-- combine the results.  But the type system cannot discover that the two
+-- results are of the same depth (and thus combinable).  We need a type
+-- that says a function preserves depth.  Here it is:
+
+data Hom a b = (a -> b) :&: Hom (Pair a) (Pair b)
+
+-- A homogeneous (or depth-preserving) function is an infinite sequence of
+-- functions of type Pair^n a -> Pair^n b, one for each depth n.  We can
+-- apply a homogeneous function to a powertree by selecting the function
+-- for the required depth:
+
+apply :: Hom a b -> Pow a -> Pow b
+apply (f :&: fs) (Zero x) = Zero (f x)
+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)
+	first (f :&: fs) =
+		first f :&: (arr transpose >>> first fs >>> arr transpose)
+
+transpose :: ((a,b), (c,d)) -> ((a,c), (b,d))
+transpose ((a,b), (c,d)) = ((a,c), (b,d))
+
+-- arr maps f over the leaves of a powertree.
+
+-- The composition >>> composes sequences of functions pairwise.
+--  
+-- The *** operator unriffles a powertree of pairs into a pair of powertrees,
+-- applies the appropriate function to each and riffles the results.
+-- It defines a categorical product for this arrow category.
+
+-- When describing algorithms, one often provides a pure function for the
+-- base case (trees of one element) and a (usually recursive) expression
+-- for trees of pairs.
+
+-- For example, a common divide-and-conquer pattern is the butterfly, where
+-- one recursive call processes the odd-numbered elements and the other
+-- processes the even ones (cf Geraint Jones and Mary Sheeran's Ruby papers):
+
+butterfly :: (Pair a -> Pair a) -> Hom a a
+butterfly f = id :&: proc (x, y) -> do
+		x' <- butterfly f -< x
+		y' <- butterfly f -< y
+		returnA -< f (x', y')
+
+-- The recursive calls operate on halves of the original tree, so the
+-- recursion is well-defined.
+
+-- Some examples of butterflies:
+
+rev :: Hom a a
+rev = butterfly swap
+	where	swap (x, y) = (y, x)
+
+unriffle :: Hom (Pair a) (Pair a)
+unriffle = butterfly transpose
+
+-- Batcher's sorter for bitonic sequences:
+
+bisort :: Ord a => Hom a a
+bisort = butterfly cmp
+	where	cmp (x, y) = (min x y, max x y)
+
+-- This can be used (with rev) as the merge phase of a merge sort.
+--  
+sort :: Ord a => Hom a a
+sort = id :&: proc (x, y) -> do
+		x' <- sort -< x
+		y' <- sort -< y
+		yr <- rev -< y'
+		p <- unriffle -< (x', yr)
+		bisort2 -< p
+	where _ :&: bisort2 = bisort
+
+-- Here is the scan operation, using the algorithm of Ladner and Fischer:
+
+scan :: (a -> a -> a) -> a -> Hom a a
+scan op b = id :&: proc (x, y) -> do
+		y' <- scan op b -< op x y
+		l <- rsh b -< y'
+		returnA -< (op l x, y')
+
+-- The auxiliary function rsh b shifts each element in the tree one place to
+-- the right, placing b in the now-vacant leftmost position, and discarding
+-- the old rightmost element:
+
+rsh :: a -> Hom a a
+rsh b = const b :&: proc (x, y) -> do
+		w <- rsh b -< y
+		returnA -< (w, x)
+
+-- Finally, here is the Fast Fourier Transform:
+
+type C = Complex Double
+
+fft :: Hom C C
+fft = id :&: proc (x, y) -> do
+		x' <- fft -< x
+		y' <- fft -< y
+		r <- roots (-1) -< ()
+		let z = r*y'
+		unriffle -< (x' + z, x' - z)
+
+-- The auxiliary function roots r (where r is typically a root of unity)
+-- populates a tree of size n (necessarily a power of 2) with the values
+-- 1, w, w^2, ..., w^(n-1), where w^n = r.
+
+roots :: C -> Hom () C
+roots r = const 1 :&: proc _ -> do
+		x <- roots r' -< ()
+		unriffle -< (x, x*r')
+	where	r' = if imagPart s >= 0 then -s else s
+		s = sqrt r
+
+-- Miscellaneous functions:
+
+rrot :: Hom a a
+rrot = id :&: proc (x, y) -> do
+		w <- rrot -< y
+		returnA -< (w, x)
+
+ilv :: Hom a a -> Hom (Pair a) (Pair a)
+ilv f = proc (x, y) -> do
+		x' <- f -< x
+		y' <- f -< y
+		returnA -< (x', y')
+
+scan' :: (a -> a -> a) -> a -> Hom a a
+scan' op b = proc x -> do
+		l <- rsh b -< x
+		(id :&: ilv (scan' op b)) -< op l x
+
+riffle :: Hom (Pair a) (Pair a)
+riffle = id :&: proc ((x1, y1), (x2, y2)) -> do
+		x <- riffle -< (x1, x2)
+		y <- riffle -< (y1, y2)
+		returnA -< (x, y)
+
+invert :: Hom a a
+invert = id :&: proc (x, y) -> do
+		x' <- invert -< x
+		y' <- invert -< y
+		unriffle -< (x', y')
+
+carryLookaheadAdder :: Hom (Bool, Bool) Bool
+carryLookaheadAdder = proc (x, y) -> do
+		carryOut <- rsh (Just False) -<
+			if x == y then Just x else Nothing
+		Just carryIn <- scan plusMaybe Nothing -< carryOut
+		returnA -< x `xor` y `xor` carryIn
+	where	plusMaybe x Nothing = x
+		plusMaybe x (Just y) = Just y
+		False `xor` b = b
+		True `xor` b = not b
+
+-- Global conditional for SIMD
+
+ifAll :: Hom a b -> Hom a b -> Hom (a, Bool) b
+ifAll fs gs = ifAllAux snd (arr fst >>> fs) (arr fst >>> gs)
+	where	ifAllAux :: (a -> Bool) -> Hom a b -> Hom a b -> Hom a b
+		ifAllAux p (f :&: fs) (g :&: gs) =
+			liftIf p f g :&: ifAllAux (liftAnd p) fs gs
+		liftIf p f g x = if p x then f x else g x
+		liftAnd p (x, y) = p x && p y
+
+maybeAll :: Hom a c -> Hom (a, b) c -> Hom (a, Maybe b) c
+maybeAll (n :&: ns) (j :&: js) =
+	choose :&: (arr dist >>> maybeAll ns (arr transpose >>> js))
+	where	choose (a, Nothing) = n a
+		choose (a, Just b) = j (a, b)
+		dist ((a1, b1), (a2, b2)) = ((a1, a2), zipMaybe b1 b2)
+		zipMaybe (Just x) (Just y) = Just (x, y)
+		zipMaybe _ _ = Nothing
+
+main = do
+	print (apply rev tree3)
+	print (apply invert tree3)
+	print (apply (invert >>> sort) tree3)
+	print (apply (scan (+) 0) tree3)
diff --git a/testsuite/tests/arrows/should_run/arrowrun002.stdout b/testsuite/tests/arrows/should_run/arrowrun002.stdout
new file mode 100644
index 0000000000..b13ce3b37a
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/arrowrun002.stdout
@@ -0,0 +1,4 @@
+Succ (Succ (Succ (Zero (((8,7),(6,5)),((4,3),(2,1))))))
+Succ (Succ (Succ (Zero (((1,5),(3,7)),((2,6),(4,8))))))
+Succ (Succ (Succ (Zero (((1,2),(3,4)),((5,6),(7,8))))))
+Succ (Succ (Succ (Zero (((1,3),(6,10)),((15,21),(28,36))))))
diff --git a/testsuite/tests/arrows/should_run/arrowrun003.hs b/testsuite/tests/arrows/should_run/arrowrun003.hs
new file mode 100644
index 0000000000..5f4580ab87
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/arrowrun003.hs
@@ -0,0 +1,133 @@
+{-# LANGUAGE Arrows #-}
+
+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
+
+-- stream map instance
+
+data Stream a = Cons a (Stream a)
+
+instance Functor Stream where
+	fmap f ~(Cons a as) = Cons (f a) (fmap f as)
+
+zipStream :: Stream a -> Stream b -> Stream (a,b)
+zipStream ~(Cons a as) ~(Cons b bs) = Cons (a,b) (zipStream as bs)
+
+unzipStream :: Stream (a,b) -> (Stream a, Stream b)
+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)
+	first (StreamMap f) =
+		StreamMap (uncurry zipStream . first f . unzipStream)
+
+instance ArrowLoop StreamMap where
+	loop (StreamMap f) =
+		StreamMap (loop (unzipStream . f . uncurry zipStream))
+
+instance ArrowCircuit StreamMap where
+	delay a = StreamMap (Cons a)
+
+listToStream :: [a] -> Stream a
+listToStream = foldr Cons undefined
+
+streamToList :: Stream a -> [a]
+streamToList (Cons a as) = a:streamToList as
+
+runStreamMap :: StreamMap a b -> [a] -> [b]
+runStreamMap (StreamMap f) as =
+	take (length as) (streamToList (f (listToStream as)))
+
+-- simple automaton instance
+
+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)
+	first (Auto f) = Auto $ \(b,d) -> let (c,f') = f b in ((c,d), first f')
+
+instance ArrowLoop Auto where
+	loop (Auto f) = Auto $ \b ->
+		let	(~(c,d), f') = f (b,d)
+		in	(c, loop f')
+
+instance ArrowCircuit Auto where
+	delay a = Auto $ \a' -> (a, delay a')
+
+runAuto :: Auto a b -> [a] -> [b]
+runAuto (Auto f) [] = []
+runAuto (Auto f) (a:as) = let (b, f') = f a in b:runAuto f' as
+
+-- Some simple example circuits
+
+-- A resettable counter (first example in several Hawk papers):
+
+counter :: ArrowCircuit a => a Bool Int
+counter = proc reset -> do
+	rec	output <- returnA -< if reset then 0 else next
+		next <- delay 0 -< output+1
+	returnA -< output
+
+-- Some other basic circuits from the Hawk library.
+
+-- flush: when reset is True, return d for n ticks, otherwise copy value.
+-- (a variation on the resettable counter)
+
+flush :: ArrowCircuit a => Int -> b -> a (b, Bool) b
+flush n d = proc (value, reset) -> do
+	rec	count <- returnA -< if reset then n else max (next-1) 0
+		next <- delay 0 -< count
+	returnA -< if count > 0 then d else value
+
+-- latch: on each tick, return the last value for which reset was True,
+-- or init if there was none.
+--  
+latch :: ArrowCircuit a => b -> a (b, Bool) b
+latch init = proc (value, reset) -> do
+	rec	out <- returnA -< if reset then value else last
+		last <- delay init -< out
+	returnA -< out
+
+-- Some tests using the counter
+
+test_input = [True, False, True, False, False, True, False, True]
+test_input2 = zip [1..] test_input
+
+-- A test of the resettable counter.
+
+main = do
+	print (runStreamMap counter test_input)
+	print (runAuto counter test_input)
+	print (runStreamMap (flush 2 0) test_input2)
+	print (runAuto (flush 2 0) test_input2)
+	print (runStreamMap (latch 0) test_input2)
+	print (runAuto (latch 0) test_input2)
+
+-- A step function (cf current in Lustre)
+
+step :: ArrowCircuit a => b -> a (Either b c) b
+step b = proc x -> do
+		rec	last_b <- delay b -< getLeft last_b x
+		returnA -< last_b
+	where	getLeft _ (Left b) = b
+		getLeft b (Right _) = b
diff --git a/testsuite/tests/arrows/should_run/arrowrun003.stdout b/testsuite/tests/arrows/should_run/arrowrun003.stdout
new file mode 100644
index 0000000000..21a7156d60
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/arrowrun003.stdout
@@ -0,0 +1,6 @@
+[0,1,0,1,2,0,1,0]
+[0,1,0,1,2,0,1,0]
+[0,0,0,0,5,0,0,0]
+[0,0,0,0,5,0,0,0]
+[1,1,3,3,3,6,6,8]
+[1,1,3,3,3,6,6,8]
diff --git a/testsuite/tests/arrows/should_run/arrowrun004.hs b/testsuite/tests/arrows/should_run/arrowrun004.hs
new file mode 100644
index 0000000000..c0275065f2
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/arrowrun004.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE Arrows, MultiParamTypeClasses, FlexibleInstances #-}
+
+-- Simple expression parser
+-- (uses do-notation and operators)
+
+module Main(main) where
+
+import Control.Arrow
+import Control.Category
+import Data.Char
+import Prelude hiding (id, (.))
+
+-- Parsers
+
+class (Eq s, Show s, ArrowPlus a) => ArrowParser s a where
+	symbol :: s -> a b String
+
+data Sym s = Sym { token :: s, value :: String }
+
+-- Simple backtracking instance
+
+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)]
+	first (BTParser f) = BTParser $ \(b,d) ss ->
+		[((c,d), ss') | (c,ss') <- f b ss]
+
+instance ArrowZero (BTParser s) where
+	zeroArrow = BTParser $ \b ss -> []
+
+instance ArrowPlus (BTParser s) where
+	BTParser f <+> BTParser g = BTParser $ \b ss -> f b ss ++ g b ss
+
+instance (Eq s, Show s) => ArrowParser s (BTParser s) where
+	symbol s = BTParser $ \b ss ->
+		case ss of
+		Sym s' v:ss' | s' == s -> [(v, ss')]
+		_ -> []
+
+runBTParser :: BTParser s () c -> [Sym s] -> c
+runBTParser (BTParser parser) syms =
+	head [c | (c, []) <- parser () syms]
+
+-- Expressions
+
+data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown
+	deriving (Show, Eq, Ord)
+
+type ExprParser = BTParser ESym
+type ExprSym = Sym ESym
+
+-- The grammar
+
+expr :: ExprParser () Int
+expr = proc () -> do
+		x <- term -< ()
+		expr' -< x
+
+expr' :: ExprParser Int Int
+expr' = proc x -> do
+		returnA -< x
+	<+> do
+		(|(symbol Plus)|)
+		y <- term -< ()
+		expr' -< x + y
+	<+> do
+		(|(symbol Minus)|)
+		y <- term -< ()
+		expr' -< x - y
+
+term :: ExprParser () Int
+term = proc () -> do
+		x <- factor -< ()
+		term' -< x
+
+term' :: ExprParser Int Int
+term' = proc x -> do
+		returnA -< x
+	<+> do
+		(|(symbol Mult)|)
+		y <- factor -< ()
+		term' -< x * y
+	<+> do
+		(|(symbol Div)|)
+		y <- factor -< ()
+		term' -< x `div` y
+
+factor :: ExprParser () Int
+factor = proc () -> do
+		v <- (|(symbol Number)|)
+		returnA -< read v::Int
+	<+> do
+		(|(symbol Minus)|)
+		v <- factor -< ()
+		returnA -< -v
+	<+> do
+		(|(symbol LPar)|)
+		v <- expr -< ()
+		(|(symbol RPar)|)
+		returnA -< v
+
+-- Lexical analysis
+
+lexer :: String -> [ExprSym]
+lexer [] = []
+lexer ('(':cs) = Sym LPar "(":lexer cs
+lexer (')':cs) = Sym RPar ")":lexer cs
+lexer ('+':cs) = Sym Plus "+":lexer cs
+lexer ('-':cs) = Sym Minus "-":lexer cs
+lexer ('*':cs) = Sym Mult "*":lexer cs
+lexer ('/':cs) = Sym Div "/":lexer cs
+lexer (c:cs)
+	| isSpace c = lexer cs
+	| isDigit c = Sym Number (c:w):lexer cs'
+	| otherwise = Sym Unknown [c]:lexer cs
+		where (w,cs') = span isDigit cs
+
+parse = runBTParser expr . lexer
+
+main = do
+	print (parse "1+2*(3+4)")
+	print (parse "3*5-17/3+4")
diff --git a/testsuite/tests/arrows/should_run/arrowrun004.stdout b/testsuite/tests/arrows/should_run/arrowrun004.stdout
new file mode 100644
index 0000000000..cbb71fdd82
--- /dev/null
+++ b/testsuite/tests/arrows/should_run/arrowrun004.stdout
@@ -0,0 +1,2 @@
+15
+14