ApplicativeDo transformation

Summary:
This is an implementation of the ApplicativeDo proposal.  See the Note
[ApplicativeDo] in RnExpr for details on the current implementation,
and the wiki page https://ghc.haskell.org/trac/ghc/wiki/ApplicativeDo
for design notes.

Test Plan: validate

Reviewers: simonpj, goldfire, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D729

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",