summaryrefslogtreecommitdiff
path: root/testsuite
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite')
-rw-r--r--testsuite/tests/ado/Makefile3
-rw-r--r--testsuite/tests/ado/ado001.hs159
-rw-r--r--testsuite/tests/ado/ado001.stdout10
-rw-r--r--testsuite/tests/ado/ado002.hs24
-rw-r--r--testsuite/tests/ado/ado002.stderr55
-rw-r--r--testsuite/tests/ado/ado003.hs8
-rw-r--r--testsuite/tests/ado/ado003.stderr9
-rw-r--r--testsuite/tests/ado/ado004.hs247
-rw-r--r--testsuite/tests/ado/ado004.stderr28
-rw-r--r--testsuite/tests/ado/ado005.hs10
-rw-r--r--testsuite/tests/ado/ado005.stderr21
-rw-r--r--testsuite/tests/ado/ado006.hs10
-rw-r--r--testsuite/tests/ado/ado007.hs16
-rw-r--r--testsuite/tests/ado/all.T7
-rw-r--r--testsuite/tests/driver/T4437.hs3
15 files changed, 609 insertions, 1 deletions
diff --git a/testsuite/tests/ado/Makefile b/testsuite/tests/ado/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/ado/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ado/ado001.hs b/testsuite/tests/ado/ado001.hs
new file mode 100644
index 0000000000..9f8f8da752
--- /dev/null
+++ b/testsuite/tests/ado/ado001.hs
@@ -0,0 +1,159 @@
+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-}
+module Main where
+
+import Control.Applicative
+import Text.PrettyPrint
+
+(a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..]
+
+-- a | b
+test1 :: M ()
+test1 = do
+ x1 <- a
+ x2 <- b
+ const (return ()) (x1,x2)
+
+-- no parallelism
+test2 :: M ()
+test2 = do
+ x1 <- a
+ x2 <- const g x1
+ const (return ()) (x1,x2)
+
+-- a | (b;g) | e
+test3 :: M ()
+test3 = do
+ x1 <- a
+ x2 <- b
+ x3 <- const g x2
+ x4 <- e
+ return () `const` (x1,x2,x3,x4)
+
+-- (a ; (b | g)) | c
+-- or
+-- ((a | b); g) | c
+test4 :: M ()
+test4 = do
+ x1 <- a
+ x2 <- b
+ x3 <- const g x1
+ x4 <- c
+ return () `const` (x2,x3,x4)
+
+-- (a | b | c); (g | h)
+test5 :: M ()
+test5 = do
+ x1 <- a
+ x2 <- b
+ x3 <- c
+ x4 <- const g x1
+ x5 <- const h x3
+ return () `const` (x3,x4,x5)
+
+-- b/c in parallel, e/f in parallel
+-- a; (b | (c; (d; (e | (f; g)))))
+test6 :: M ()
+test6 = do
+ x1 <- a
+ x2 <- const b x1
+ x3 <- const c x1
+ x4 <- const d x3
+ x5 <- const e x4
+ x6 <- const f x4
+ x7 <- const g x6
+ return () `const` (x1,x2,x3,x4,x5,x6,x7)
+
+-- (a | b); (c | d)
+test7 :: M ()
+test7 = do
+ x1 <- a
+ x2 <- b
+ x3 <- const c x1
+ x4 <- const d x2
+ return () `const` (x3,x4)
+
+-- a; (b | c | d)
+--
+-- alternative (but less good):
+-- ((a;b) | c); d
+test8 :: M ()
+test8 = do
+ x1 <- a
+ x2 <- const b x1
+ x3 <- c
+ x4 <- const d x1
+ return () `const` (x2,x3,x4)
+
+-- test that Lets don't get in the way
+-- ((a | (b; c)) | d) | e
+test9 :: M ()
+test9 = do
+ x1 <- a
+ let x = doc "x" -- this shouldn't get in the way of grouping a/b
+ x2 <- b
+ x3 <- const c x2
+ x4 <- d
+ x5 <- e
+ let y = doc "y"
+ return ()
+
+-- ((a | b) ; (c | d)) | e
+test10 :: M ()
+test10 = do
+ x1 <- a
+ x2 <- b
+ let z1 = (x1,x2)
+ x3 <- const c x1
+ let z2 = (x1,x2)
+ x4 <- const d z1
+ x5 <- e
+ return (const () (x3,x4,x5))
+
+main = mapM_ run
+ [ test1
+ , test2
+ , test3
+ , test4
+ , test5
+ , test6
+ , test7
+ , test8
+ , test9
+ , test10
+ ]
+
+-- Testing code, prints out the structure of a monad/applicative expression
+
+newtype M a = M (Bool -> (Maybe Doc, a))
+
+maybeParen True d = parens d
+maybeParen _ d = d
+
+run :: M a -> IO ()
+run (M m) = print d where (Just d,_) = m False
+
+instance Functor M where
+ fmap f m = m >>= return . f
+
+instance Applicative M where
+ pure a = M $ \_ -> (Nothing, a)
+ M f <*> M a = M $ \p ->
+ let (Just d1, f') = f True
+ (Just d2, a') = a True
+ in
+ (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a')
+
+instance Monad M where
+ return = pure
+ M m >>= k = M $ \p ->
+ let (d1, a) = m True
+ (d2, b) = case k a of M f -> f True
+ in
+ case (d1,d2) of
+ (Nothing,Nothing) -> (Nothing, b)
+ (Just d, Nothing) -> (Just d, b)
+ (Nothing, Just d) -> (Just d, b)
+ (Just d1, Just d2) -> (Just (maybeParen p (d1 <> semi <+> d2)), b)
+
+doc :: String -> M ()
+doc d = M $ \_ -> (Just (text d), ())
diff --git a/testsuite/tests/ado/ado001.stdout b/testsuite/tests/ado/ado001.stdout
new file mode 100644
index 0000000000..93e300cb42
--- /dev/null
+++ b/testsuite/tests/ado/ado001.stdout
@@ -0,0 +1,10 @@
+(a | b)
+a; g
+((a | (b; g)) | e)
+(((a | b); g) | c)
+((a | b) | c); (g | h)
+a; (b | (c; (d; (e | (f; g)))))
+(a | b); (c | d)
+a; ((b | c) | d)
+((a | (b; c)) | d) | e
+((a | b); (c | d)) | e
diff --git a/testsuite/tests/ado/ado002.hs b/testsuite/tests/ado/ado002.hs
new file mode 100644
index 0000000000..f4d4d93361
--- /dev/null
+++ b/testsuite/tests/ado/ado002.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE ApplicativeDo,ScopedTypeVariables #-}
+module Test where
+
+-- Test that type errors aren't affected by ApplicativeDo
+f :: IO Int
+f = do
+ x <- getChar
+ y <- getChar 'a' -- type error
+ print (x,y)
+
+g :: IO (Int,Int)
+g = do
+ x <- getChar
+ y <- getChar
+ return (y,x)
+
+h :: IO (Int,Int)
+h = do
+ x1 <- getChar
+ x2 <- getChar
+ x3 <- const (return ()) x1
+ x4 <- getChar
+ x5 <- getChar x4
+ return (x2,x4)
diff --git a/testsuite/tests/ado/ado002.stderr b/testsuite/tests/ado/ado002.stderr
new file mode 100644
index 0000000000..cdfdbc4b19
--- /dev/null
+++ b/testsuite/tests/ado/ado002.stderr
@@ -0,0 +1,55 @@
+
+ado002.hs:8:8: error:
+ Couldn't match expected type ‘Char -> IO t1’
+ with actual type ‘IO Char’
+ The function ‘getChar’ is applied to one argument,
+ but its type ‘IO Char’ has none
+ In a stmt of a 'do' block: y <- getChar 'a'
+ In the expression:
+ do { x <- getChar;
+ y <- getChar 'a';
+ print (x, y) }
+
+ado002.hs:9:3: error:
+ Couldn't match type ‘()’ with ‘Int’
+ Expected type: IO Int
+ Actual type: IO ()
+ In a stmt of a 'do' block: print (x, y)
+ In the expression:
+ do { x <- getChar;
+ y <- getChar 'a';
+ print (x, y) }
+
+ado002.hs:15:11: error:
+ Couldn't match expected type ‘Int’ with actual type ‘Char’
+ In the expression: y
+ In a stmt of a 'do' block: return (y, x)
+
+ado002.hs:15:13: error:
+ Couldn't match expected type ‘Int’ with actual type ‘Char’
+ In the expression: x
+ In a stmt of a 'do' block: return (y, x)
+
+ado002.hs:23:9: error:
+ Couldn't match expected type ‘Char -> IO t0’
+ with actual type ‘IO Char’
+ The function ‘getChar’ is applied to one argument,
+ but its type ‘IO Char’ has none
+ In a stmt of a 'do' block: x5 <- getChar x4
+ In the expression:
+ do { x1 <- getChar;
+ x2 <- getChar;
+ x3 <- const (return ()) x1;
+ x4 <- getChar;
+ x5 <- getChar x4;
+ return (x2, x4) }
+
+ado002.hs:24:11: error:
+ Couldn't match expected type ‘Int’ with actual type ‘Char’
+ In the expression: x2
+ In a stmt of a 'do' block: return (x2, x4)
+
+ado002.hs:24:14: error:
+ Couldn't match expected type ‘Int’ with actual type ‘Char’
+ In the expression: x4
+ In a stmt of a 'do' block: return (x2, x4)
diff --git a/testsuite/tests/ado/ado003.hs b/testsuite/tests/ado/ado003.hs
new file mode 100644
index 0000000000..622968dfae
--- /dev/null
+++ b/testsuite/tests/ado/ado003.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE ApplicativeDo #-}
+module ShouldFail where
+
+g :: IO ()
+g = do
+ x <- getChar
+ 'a' <- return (3::Int) -- type error
+ return ()
diff --git a/testsuite/tests/ado/ado003.stderr b/testsuite/tests/ado/ado003.stderr
new file mode 100644
index 0000000000..5d04f15896
--- /dev/null
+++ b/testsuite/tests/ado/ado003.stderr
@@ -0,0 +1,9 @@
+
+ado003.hs:7:3: error:
+ Couldn't match expected type ‘Int’ with actual type ‘Char’
+ In the pattern: 'a'
+ In a stmt of a 'do' block: 'a' <- return (3 :: Int)
+ In the expression:
+ do { x <- getChar;
+ 'a' <- return (3 :: Int);
+ return () }
diff --git a/testsuite/tests/ado/ado004.hs b/testsuite/tests/ado/ado004.hs
new file mode 100644
index 0000000000..67e04c117a
--- /dev/null
+++ b/testsuite/tests/ado/ado004.hs
@@ -0,0 +1,247 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# OPTIONS_GHC -ddump-types #-}
+module Test where
+
+-- This is a do expression that typechecks with only an Applicative constraint
+test1 :: Applicative f => (Int -> f Int) -> f Int
+test1 f = do
+ x <- f 3
+ y <- f 4
+ return (x + y)
+
+-- Test we can also infer the Applicative version of the type
+test2 f = do
+ x <- f 3
+ y <- f 4
+ return (x + y)
+
+-- This one will use join
+test3 f g = do
+ x <- f 3
+ y <- f 4
+ g y x
+
+-- This one needs a tuple
+test4 f g = do
+ x <- f 3
+ y <- f 4
+ let r = g y x
+ r
+
+-- This one used to need a big tuple, now it compiles to ApplicativeLastStmt
+test5 f g = do
+ x01 <- f 01
+ x02 <- f 02
+ x03 <- f 03
+ x04 <- f 04
+ x05 <- f 05
+ x06 <- f 06
+ x07 <- f 07
+ x08 <- f 08
+ x09 <- f 09
+ x11 <- f 11
+ x12 <- f 12
+ x13 <- f 13
+ x14 <- f 14
+ x15 <- f 15
+ x16 <- f 16
+ x17 <- f 17
+ x18 <- f 18
+ x19 <- f 19
+ x20 <- f 20
+ x21 <- f 21
+ x22 <- f 22
+ x23 <- f 23
+ x24 <- f 24
+ x25 <- f 25
+ x26 <- f 26
+ x27 <- f 27
+ x28 <- f 28
+ x29 <- f 29
+ x30 <- f 30
+ x31 <- f 31
+ x32 <- f 32
+ x33 <- f 33
+ x34 <- f 34
+ x35 <- f 35
+ x36 <- f 36
+ x37 <- f 37
+ x38 <- f 38
+ x39 <- f 39
+ x40 <- f 40
+ x41 <- f 41
+ x42 <- f 42
+ x43 <- f 43
+ x44 <- f 44
+ x45 <- f 45
+ x46 <- f 46
+ x47 <- f 47
+ x48 <- f 48
+ x49 <- f 49
+ x50 <- f 50
+ x51 <- f 51
+ x52 <- f 52
+ x53 <- f 53
+ x54 <- f 54
+ x55 <- f 55
+ x56 <- f 56
+ x57 <- f 57
+ x58 <- f 58
+ x59 <- f 59
+ x60 <- f 60
+ x61 <- f 61
+ x62 <- f 62
+ x63 <- f 63
+ x64 <- f 64
+ x65 <- f 65
+ x66 <- f 66
+ x67 <- f 67
+ x68 <- f 68
+ x69 <- f 69
+ x70 <- f 70
+ let r = g x70 x01
+ r
+
+-- This one needs a big tuple
+test6 f g = do
+ x01 <- f 01
+ x02 <- f 02
+ x03 <- f 03
+ x04 <- f 04
+ x05 <- f 05
+ x06 <- f 06
+ x07 <- f 07
+ x08 <- f 08
+ x09 <- f 09
+ x11 <- f 11
+ x12 <- f 12
+ x13 <- f 13
+ x14 <- f 14
+ x15 <- f 15
+ x16 <- f 16
+ x17 <- f 17
+ x18 <- f 18
+ x19 <- f 19
+ x20 <- f 20
+ x21 <- f 21
+ x22 <- f 22
+ x23 <- f 23
+ x24 <- f 24
+ x25 <- f 25
+ x26 <- f 26
+ x27 <- f 27
+ x28 <- f 28
+ x29 <- f 29
+ x30 <- f 30
+ x31 <- f 31
+ x32 <- f 32
+ x33 <- f 33
+ x34 <- f 34
+ x35 <- f 35
+ x36 <- f 36
+ x37 <- f 37
+ x38 <- f 38
+ x39 <- f 39
+ x40 <- f 40
+ x41 <- f 41
+ x42 <- f 42
+ x43 <- f 43
+ x44 <- f 44
+ x45 <- f 45
+ x46 <- f 46
+ x47 <- f 47
+ x48 <- f 48
+ x49 <- f 49
+ x50 <- f 50
+ x51 <- f 51
+ x52 <- f 52
+ x53 <- f 53
+ x54 <- f 54
+ x55 <- f 55
+ x56 <- f 56
+ x57 <- f 57
+ x58 <- f 58
+ x59 <- f 59
+ x60 <- f 60
+ x61 <- f 61
+ x62 <- f 62
+ x63 <- f 63
+ x64 <- f 64
+ x65 <- f 65
+ x66 <- f 66
+ x67 <- f 67
+ x68 <- f 68
+ x69 <- f 69
+ x70 <- f x01
+ x71 <- f 70
+ x71 `const`
+ [ x01
+ , x02
+ , x03
+ , x04
+ , x05
+ , x06
+ , x07
+ , x08
+ , x09
+ , x11
+ , x12
+ , x13
+ , x14
+ , x15
+ , x16
+ , x17
+ , x18
+ , x19
+ , x20
+ , x21
+ , x22
+ , x23
+ , x24
+ , x25
+ , x26
+ , x27
+ , x28
+ , x29
+ , x30
+ , x31
+ , x32
+ , x33
+ , x34
+ , x35
+ , x36
+ , x37
+ , x38
+ , x39
+ , x40
+ , x41
+ , x42
+ , x43
+ , x44
+ , x45
+ , x46
+ , x47
+ , x48
+ , x49
+ , x50
+ , x51
+ , x52
+ , x53
+ , x54
+ , x55
+ , x56
+ , x57
+ , x58
+ , x59
+ , x60
+ , x61
+ , x62
+ , x63
+ , x64
+ , x65
+ , x66
+ , x67
+ , x68
+ , x69
+ , x70
+ , x71 ]
diff --git a/testsuite/tests/ado/ado004.stderr b/testsuite/tests/ado/ado004.stderr
new file mode 100644
index 0000000000..691a09e7d6
--- /dev/null
+++ b/testsuite/tests/ado/ado004.stderr
@@ -0,0 +1,28 @@
+TYPE SIGNATURES
+ test1 ::
+ forall (f :: * -> *). Applicative f => (Int -> f Int) -> f Int
+ test2 ::
+ forall (f :: * -> *) b a.
+ (Num b, Num a, Applicative f) =>
+ (a -> f b) -> f b
+ test3 ::
+ forall (m :: * -> *) a a1 a2.
+ (Monad m, Num a2) =>
+ (a2 -> m a1) -> (a1 -> a1 -> m a) -> m a
+ test4 ::
+ forall (m :: * -> *) a a1 a2.
+ (Monad m, Num a2) =>
+ (a2 -> m a1) -> (a1 -> a1 -> m a) -> m a
+ test5 ::
+ forall (m :: * -> *) a a1 a2.
+ (Monad m, Num a2) =>
+ (a2 -> m a1) -> (a1 -> a1 -> m a) -> m a
+ test6 ::
+ forall t (m :: * -> *) a.
+ (Monad m, Num (m a)) =>
+ (m a -> m (m a)) -> t -> m a
+TYPE CONSTRUCTORS
+COERCION AXIOMS
+Dependent modules: []
+Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
+ integer-gmp-1.0.0.0]
diff --git a/testsuite/tests/ado/ado005.hs b/testsuite/tests/ado/ado005.hs
new file mode 100644
index 0000000000..97dbeedcb5
--- /dev/null
+++ b/testsuite/tests/ado/ado005.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# OPTIONS_GHC -ddump-types #-}
+module Test where
+
+-- This should fail to typecheck because it needs Monad
+test :: Applicative f => (Int -> f Int) -> f Int
+test f = do
+ x <- f 3
+ y <- f x
+ return (x + y)
diff --git a/testsuite/tests/ado/ado005.stderr b/testsuite/tests/ado/ado005.stderr
new file mode 100644
index 0000000000..7203392d60
--- /dev/null
+++ b/testsuite/tests/ado/ado005.stderr
@@ -0,0 +1,21 @@
+
+ado005.hs:8:3:
+ Could not deduce (Monad f) arising from a do statement
+ from the context: Applicative f
+ bound by the type signature for:
+ test :: Applicative f => (Int -> f Int) -> f Int
+ at ado005.hs:6:9-48
+ Possible fix:
+ add (Monad f) to the context of
+ the type signature for:
+ test :: Applicative f => (Int -> f Int) -> f Int
+ In a stmt of a 'do' block: x <- f 3
+ In the expression:
+ do { x <- f 3;
+ y <- f x;
+ return (x + y) }
+ In an equation for ‘test’:
+ test f
+ = do { x <- f 3;
+ y <- f x;
+ return (x + y) }
diff --git a/testsuite/tests/ado/ado006.hs b/testsuite/tests/ado/ado006.hs
new file mode 100644
index 0000000000..1cba57c4c9
--- /dev/null
+++ b/testsuite/tests/ado/ado006.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ApplicativeDo #-}
+module Test where
+
+-- This exposed a bug in zonking ApplicativeLastStmt
+test :: IO Int
+test
+ = do
+ x <- return ()
+ h <- return (\_ -> 3)
+ return (h ())
diff --git a/testsuite/tests/ado/ado007.hs b/testsuite/tests/ado/ado007.hs
new file mode 100644
index 0000000000..3017222311
--- /dev/null
+++ b/testsuite/tests/ado/ado007.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE RebindableSyntax #-}
+module Test where
+
+import Control.Applicative
+import Control.Monad
+import Prelude
+
+-- Caused a -dcore-lint failure with an earlier version of
+-- ApplicativeDo due to the polymorphic let binding.
+test :: IO [Char]
+test = do
+ x <- return 'a'
+ y <- return 'b'
+ let f | y == 'c' = id | otherwise = id
+ return (map f [])
diff --git a/testsuite/tests/ado/all.T b/testsuite/tests/ado/all.T
new file mode 100644
index 0000000000..2ec3e341e8
--- /dev/null
+++ b/testsuite/tests/ado/all.T
@@ -0,0 +1,7 @@
+test('ado001', normal, compile_and_run, [''])
+test('ado002', normal, compile_fail, [''])
+test('ado003', normal, compile_fail, [''])
+test('ado004', normal, compile, [''])
+test('ado005', normal, compile_fail, [''])
+test('ado006', normal, compile, [''])
+test('ado007', normal, compile, [''])
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index 3c6de35402..c197cbd5dc 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -34,7 +34,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout",
"AlternativeLayoutRule",
"AlternativeLayoutRuleTransitional",
"StaticPointers",
- "StrictData"]
+ "StrictData",
+ "ApplicativeDo"] -- TODO add this to Cabal
expectedCabalOnlyExtensions :: [String]
expectedCabalOnlyExtensions = ["Generics",
View Lorry Controller Status