13 files changed, 124 insertions, 0 deletions
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 }