Add support for ImplicitParams and RecursiveDo in TH

Summary:
This adds TH support for the ImplicitParams and RecursiveDo extensions.

I'm submitting this as one review because I cannot cleanly make
the two commits independent.

Initially, my goal was just to add ImplicitParams support, and
I found that reasonably straightforward, so figured I might
as well use my newfound knowledge to address some other TH omissions.

Test Plan: Validate

Reviewers: goldfire, austin, bgamari, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: carter, RyanGlScott, thomie

GHC Trac Issues: #1262

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

12 files changed, 124 insertions, 0 deletions

diff --git a/testsuite/tests/th/TH_implicitParams.hs b/testsuite/tests/th/TH_implicitParams.hs
new file mode 100644
index 0000000000..eb948b98ed
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParams.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE ImplicitParams #-}
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+funcToReify :: (?z :: Int) => Int
+funcToReify = ?z
+
+$( [d|
+        f :: (?x :: Int) => Int
+        f = let ?y = 2 in ?x + ?y |] )
+
+main = do
+    putStrLn $(lift . pprint =<< reify 'funcToReify)
+    print (let ?x = 3 in f)
+    print $( [| let ?x = 1 in ?x |] )
+    print $(letE [implicitParamBindD "y" (lift (2 :: Int))]
+                 (implicitParamVarE "y") )
+    putStrLn $( lift . pprint =<< [d|
+        f :: (?x :: Int) => Int
+        f = let ?y = 2 in ?x + ?y |] )
diff --git a/testsuite/tests/th/TH_implicitParams.stdout b/testsuite/tests/th/TH_implicitParams.stdout
new file mode 100644
index 0000000000..571d2e74fe
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParams.stdout
@@ -0,0 +1,8 @@
+Main.funcToReify :: GHC.Classes.IP "z" GHC.Types.Int =>
+                    GHC.Types.Int
+5
+1
+2
+f_0 :: (?x :: GHC.Types.Int) => GHC.Types.Int
+f_0 = let ?y = 2
+       in ?x GHC.Num.+ ?y
diff --git a/testsuite/tests/th/TH_implicitParamsErr1.hs b/testsuite/tests/th/TH_implicitParamsErr1.hs
new file mode 100644
index 0000000000..56cf285c59
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr1.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE TemplateHaskell #-}
+import Language.Haskell.TH
+
+$(fmap (:[]) (implicitParamBindD "x" [e| 1 |]))
diff --git a/testsuite/tests/th/TH_implicitParamsErr1.stderr b/testsuite/tests/th/TH_implicitParamsErr1.stderr
new file mode 100644
index 0000000000..82324810ad
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr1.stderr
@@ -0,0 +1,4 @@
+
+TH_implicitParamsErr1.hs:5:3: error:
+    Implicit parameter binding only allowed in let or where
+    When splicing a TH declaration: ?x = 1
diff --git a/testsuite/tests/th/TH_implicitParamsErr2.hs b/testsuite/tests/th/TH_implicitParamsErr2.hs
new file mode 100644
index 0000000000..5b8ad90e81
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr2.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE TemplateHaskell #-}
+import Language.Haskell.TH
+
+main = $(letE [ implicitParamBindD "x" [e| 1 |]
+              , funD (mkName "y") [clause [] (normalB [e| 2 |]) []]
+              ]
+              (varE (mkName "y")))
diff --git a/testsuite/tests/th/TH_implicitParamsErr2.stderr b/testsuite/tests/th/TH_implicitParamsErr2.stderr
new file mode 100644
index 0000000000..f93aa55a58
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr2.stderr
@@ -0,0 +1,10 @@
+
+TH_implicitParamsErr2.hs:5:10: error:
+    • Implicit parameters mixed with other bindings
+      When splicing a TH expression: let {?x = 1; y = 2}
+ in y
+    • In the untyped splice:
+        $(letE
+            [implicitParamBindD "x" [| 1 |],
+             funD (mkName "y") [clause [] (normalB [| 2 |]) []]]
+            (varE (mkName "y")))
diff --git a/testsuite/tests/th/TH_implicitParamsErr3.hs b/testsuite/tests/th/TH_implicitParamsErr3.hs
new file mode 100644
index 0000000000..b217d60846
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr3.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE TemplateHaskell #-}
+import Language.Haskell.TH
+
+main = print $(letE [implicitParamBindD "invalid name" [e| "hi" |]]
+                    (implicitParamVarE "invalid name"))
diff --git a/testsuite/tests/th/TH_implicitParamsErr3.stderr b/testsuite/tests/th/TH_implicitParamsErr3.stderr
new file mode 100644
index 0000000000..fe3bf67259
--- /dev/null
+++ b/testsuite/tests/th/TH_implicitParamsErr3.stderr
@@ -0,0 +1,10 @@
+
+TH_implicitParamsErr3.hs:5:16: error:
+    • Illegal variable name: ‘invalid name’
+      When splicing a TH expression:
+        let ?invalid name = "hi"
+ in ?invalid name
+    • In the untyped splice:
+        $(letE
+            [implicitParamBindD "invalid name" [| "hi" |]]
+            (implicitParamVarE "invalid name"))
diff --git a/testsuite/tests/th/TH_recursiveDo.hs b/testsuite/tests/th/TH_recursiveDo.hs
new file mode 100644
index 0000000000..f193cf7088
--- /dev/null
+++ b/testsuite/tests/th/TH_recursiveDo.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE RecursiveDo #-}
+import Data.IORef
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import TH_recursiveDoImport
+
+main = testRec >> testMdo
+
+testRec = do
+    putStrLn $(lift . pprint =<< recIO)
+    -- Test that we got the expected structure.
+    SelfRef r1 <- $(recIO)
+    r2 <- readIORef r1
+    SelfRef r1' <- readIORef r2
+    print (r1 == r1')
+
+testMdo =
+    putStrLn $(lift . pprint =<< mdoIO)
diff --git a/testsuite/tests/th/TH_recursiveDo.stdout b/testsuite/tests/th/TH_recursiveDo.stdout
new file mode 100644
index 0000000000..5508b5dcdc
--- /dev/null
+++ b/testsuite/tests/th/TH_recursiveDo.stdout
@@ -0,0 +1,7 @@
+do {rec {r1_0 <- GHC.IORef.newIORef r2_1;
+         r2_1 <- GHC.IORef.newIORef (TH_recursiveDoImport.SelfRef r1_0)};
+    GHC.IORef.readIORef r2_1}
+True
+mdo {rec {r1_0 <- GHC.Base.return r2_1;
+          r2_1 <- GHC.Base.return (GHC.Base.const 1 r1_0)};
+     GHC.Base.return r1_0}
diff --git a/testsuite/tests/th/TH_recursiveDoImport.hs b/testsuite/tests/th/TH_recursiveDoImport.hs
new file mode 100644
index 0000000000..519987863f
--- /dev/null
+++ b/testsuite/tests/th/TH_recursiveDoImport.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE RecursiveDo #-}
+module TH_recursiveDoImport where
+import Data.IORef
+import Language.Haskell.TH
+
+data SelfRef = SelfRef (IORef (IORef SelfRef))
+
+recIO :: ExpQ
+recIO = [e|
+    do rec r1 <- newIORef r2
+           r2 <- newIORef (SelfRef r1)
+       readIORef r2 |]
+
+mdoIO :: ExpQ
+mdoIO = [e|
+    mdo r1 <- return r2
+        r2 <- return (const 1 r1)
+        return r1 |]
+
+emptyRecIO :: ExpQ
+emptyRecIO = [e|
+   do rec {}
+      return () |]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index cf9153e43d..9a25591937 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -429,3 +429,8 @@ test('T15550', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15502', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15518', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15572', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_implicitParams', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
+test('TH_implicitParamsErr1', normal, compile_fail, ['-v0 -dsuppress-uniques'])
+test('TH_implicitParamsErr2', normal, compile_fail, ['-v0 -dsuppress-uniques'])
+test('TH_implicitParamsErr3', normal, compile_fail, ['-v0 -dsuppress-uniques'])
+test('TH_recursiveDo', normal, compile_and_run, ['-v0 -dsuppress-uniques'])