compiler: re-engineer the treatment of rebindable if

Executing on the plan described in #17582, this patch changes the way if expressions
are handled in the compiler in the presence of rebindable syntax. We get rid of the
SyntaxExpr field of HsIf and instead, when rebindable syntax is on, we rewrite the HsIf
node to the appropriate sequence of applications of the local `ifThenElse` function.

In order to be able to report good error messages, with expressions as they were
written by the user (and not as desugared by the renamer), we make use of TTG
extensions to extend GhcRn expression ASTs with an `HsExpansion` construct, which
keeps track of a source (GhcPs) expression and the desugared (GhcRn) expression that
it gives rise to. This way, we can typecheck the latter while reporting the former in
error messages.

In order to discard the error context lines that arise from typechecking the desugared
expressions (because they talk about expressions that the user has not written), we
carefully give a special treatment to the nodes fabricated by this new renaming-time
transformation when typechecking them. See Note [Rebindable syntax and HsExpansion]
for more details. The note also includes a recipe to apply the same treatment to
other rebindable constructs.

Tests 'rebindable11' and 'rebindable12' have been added to make sure we report
identical error messages as before this patch under various circumstances.

We also now disable rebindable syntax when processing untyped TH quotes, as per
the discussion in #18102 and document the interaction of rebindable syntax and
Template Haskell, both in Note [Template Haskell quotes and Rebindable Syntax]
and in the user guide, adding a test to make sure that we do not regress in
that regard.

14 files changed, 193 insertions, 43 deletions

diff --git a/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout
index cbd4dbeb61..1d16dbf437 100644
--- a/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout
+++ b/testsuite/tests/ghc-api/show-srcspan/showsrcspan.stdout
@@ -4,4 +4,4 @@
 "RealSrcSpan SrcSpanPoint \"filename\" 1 3 Nothing"
 "RealSrcSpan SrcSpanOneLine \"filename\" 1 3 5 Nothing"
 "RealSrcSpan SrcSpanMultiLine \"filename\" 1 5 10 1 Nothing"
-"UnhelpfulSpan \"bad span\""
+"UnhelpfulSpan (UnhelpfulOther \"bad span\")"
diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
index 80fc356925..a9081bf7eb 100644
--- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
@@ -540,14 +540,15 @@
             (NoExtField)
             ({ <no location info> }
              (XExpr
-              (HsWrap
-               (WpTyApp
-                (TyConApp
-                 ({abstract:TyCon})
-                 []))
-               (HsConLikeOut
-                (NoExtField)
-                ({abstract:ConLike})))))
+              (WrapExpr
+               (HsWrap
+                (WpTyApp
+                 (TyConApp
+                  ({abstract:TyCon})
+                  []))
+                (HsConLikeOut
+                 (NoExtField)
+                 ({abstract:ConLike}))))))
             ({ <no location info> }
              (HsVar
               (NoExtField)
@@ -564,14 +565,15 @@
                 (NoExtField)
                 ({ <no location info> }
                  (XExpr
-                  (HsWrap
-                   (WpTyApp
-                    (TyConApp
-                     ({abstract:TyCon})
-                     []))
-                   (HsConLikeOut
-                    (NoExtField)
-                    ({abstract:ConLike})))))
+                  (WrapExpr
+                   (HsWrap
+                    (WpTyApp
+                     (TyConApp
+                      ({abstract:TyCon})
+                      []))
+                    (HsConLikeOut
+                     (NoExtField)
+                     ({abstract:ConLike}))))))
                 ({ <no location info> }
                  (HsVar
                   (NoExtField)
@@ -588,14 +590,15 @@
                     (NoExtField)
                     ({ <no location info> }
                      (XExpr
-                      (HsWrap
-                       (WpTyApp
-                        (TyConApp
-                         ({abstract:TyCon})
-                         []))
-                       (HsConLikeOut
-                        (NoExtField)
-                        ({abstract:ConLike})))))
+                      (WrapExpr
+                       (HsWrap
+                        (WpTyApp
+                         (TyConApp
+                          ({abstract:TyCon})
+                          []))
+                        (HsConLikeOut
+                         (NoExtField)
+                         ({abstract:ConLike}))))))
                     ({ <no location info> }
                      (HsVar
                       (NoExtField)
@@ -603,14 +606,15 @@
                        {Var: $krep})))))
                   ({ <no location info> }
                    (XExpr
-                    (HsWrap
-                     (WpTyApp
-                      (TyConApp
-                       ({abstract:TyCon})
-                       []))
-                     (HsConLikeOut
-                      (NoExtField)
-                      ({abstract:ConLike})))))))))))))))))))))
+                    (WrapExpr
+                     (HsWrap
+                      (WpTyApp
+                       (TyConApp
+                        ({abstract:TyCon})
+                        []))
+                      (HsConLikeOut
+                       (NoExtField)
+                       ({abstract:ConLike}))))))))))))))))))))))
  ,({ <no location info> }
    (VarBind
     (NoExtField)
@@ -632,14 +636,15 @@
            {Var: DumpTypecheckedAst.$tcPeano})))))
       ({ <no location info> }
        (XExpr
-        (HsWrap
-         (WpTyApp
-          (TyConApp
-           ({abstract:TyCon})
-           []))
-         (HsConLikeOut
-          (NoExtField)
-          ({abstract:ConLike})))))))))
+        (WrapExpr
+         (HsWrap
+          (WpTyApp
+           (TyConApp
+            ({abstract:TyCon})
+            []))
+          (HsConLikeOut
+           (NoExtField)
+           ({abstract:ConLike}))))))))))
  ,({ <no location info> }
    (VarBind
     (NoExtField)
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
index 610a0c188e..9481f6e018 100644
--- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
+++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
@@ -53,9 +53,9 @@ typecheckPlugin [name, "typecheck"] _ tc
 typecheckPlugin _ _ tc = return tc
 
 metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
-metaPlugin' [name, "meta"] (L l (HsPar x (L _ (XExpr (HsWrap w (HsApp noExt (L _ (HsVar _ (L _ id))) e))))))
+metaPlugin' [name, "meta"] (L l (HsPar x (L _ (XExpr (WrapExpr (HsWrap w (HsApp noExt (L _ (HsVar _ (L _ id))) e)))))))
   | occNameString (getOccName id) == name
-  = return (L l (XExpr (HsWrap w (unLoc e))))
+  = return (L l (XExpr (WrapExpr (HsWrap w (unLoc e)))))
 -- The test should always match this first case. If the desugaring changes
 -- again in the future then the panic is more useful than the previous
 -- inscrutable failure.
diff --git a/testsuite/tests/rebindable/all.T b/testsuite/tests/rebindable/all.T
index 2caa486d9b..49f77d607e 100644
--- a/testsuite/tests/rebindable/all.T
+++ b/testsuite/tests/rebindable/all.T
@@ -20,6 +20,8 @@ test('rebindable7', normal, compile_and_run, [''])
 test('rebindable8', normal, compile, [''])
 test('rebindable9', normal, compile, [''])
 test('rebindable10', normal, compile_and_run, [''])
+test('rebindable11', normal, compile_fail, [''])
+test('rebindable12', normal, compile_fail, [''])
 test('RebindableFailA', exit_code(1), compile_and_run, [''])
 test('RebindableFailB', normal, compile_and_run, [''])
 
diff --git a/testsuite/tests/rebindable/rebindable11.hs b/testsuite/tests/rebindable/rebindable11.hs
new file mode 100644
index 0000000000..747fb232d3
--- /dev/null
+++ b/testsuite/tests/rebindable/rebindable11.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE StaticPointers #-}
+module Rebindable11 where
+
+import Prelude
+
+ifThenElse :: Bool -> () -> () -> Int
+ifThenElse cond b1 b2 = 0
+
+a1 = let foo = if 'a' then () else () in foo*foo
+a2 = (if 'a' then () else ())*2 + 1
+a3 = if 'a' then () else ()
+a4 = if (if 'a' then () else ()) == 10 then () else ()
+a5 = static (if 'a' then () else ())
+a6 = (if 'a' then () else ()) :: Int
+
+data A = A { field :: Int }
+a7 = A { field = if 'a' then () else () }
+a8 = let someA = A 10 in someA { field = if True == 'a' then () else () }
diff --git a/testsuite/tests/rebindable/rebindable11.stderr b/testsuite/tests/rebindable/rebindable11.stderr
new file mode 100644
index 0000000000..1aaca7af79
--- /dev/null
+++ b/testsuite/tests/rebindable/rebindable11.stderr
@@ -0,0 +1,49 @@
+
+rebindable11.hs:10:19: error:
+    • Couldn't match expected type ‘Bool’ with actual type ‘Char’
+    • In the expression: 'a'
+      In the expression: if 'a' then () else ()
+      In an equation for ‘foo’: foo = if 'a' then () else ()
+
+rebindable11.hs:11:10: error:
+    • Couldn't match expected type ‘Bool’ with actual type ‘Char’
+    • In the expression: 'a'
+      In the first argument of ‘(*)’, namely ‘(if 'a' then () else ())’
+      In the first argument of ‘(+)’, namely
+        ‘(if 'a' then () else ()) * 2’
+
+rebindable11.hs:12:9: error:
+    • Couldn't match expected type ‘Bool’ with actual type ‘Char’
+    • In the expression: 'a'
+      In the expression: if 'a' then () else ()
+      In an equation for ‘a3’: a3 = if 'a' then () else ()
+
+rebindable11.hs:13:13: error:
+    • Couldn't match expected type ‘Bool’ with actual type ‘Char’
+    • In the expression: 'a'
+      In the first argument of ‘(==)’, namely ‘(if 'a' then () else ())’
+      In the expression: (if 'a' then () else ()) == 10
+
+rebindable11.hs:14:17: error:
+    • Couldn't match expected type ‘Bool’ with actual type ‘Char’
+    • In the expression: 'a'
+      In the body of a static form: (if 'a' then () else ())
+      In the expression: static (if 'a' then () else ())
+
+rebindable11.hs:15:10: error:
+    • Couldn't match expected type ‘Bool’ with actual type ‘Char’
+    • In the expression: 'a'
+      In the expression: (if 'a' then () else ()) :: Int
+      In an equation for ‘a6’: a6 = (if 'a' then () else ()) :: Int
+
+rebindable11.hs:18:21: error:
+    • Couldn't match expected type ‘Bool’ with actual type ‘Char’
+    • In the expression: 'a'
+      In the ‘field’ field of a record
+      In the expression: A {field = if 'a' then () else ()}
+
+rebindable11.hs:19:53: error:
+    • Couldn't match expected type ‘Bool’ with actual type ‘Char’
+    • In the second argument of ‘(==)’, namely ‘'a'’
+      In the expression: True == 'a'
+      In the ‘field’ field of a record
diff --git a/testsuite/tests/rebindable/rebindable12.hs b/testsuite/tests/rebindable/rebindable12.hs
new file mode 100644
index 0000000000..5fa4d07790
--- /dev/null
+++ b/testsuite/tests/rebindable/rebindable12.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE RebindableSyntax #-}
+module Rebindable12 where
+
+import Prelude
+
+ifThenElse :: Char -> () -> () -> () -> ()
+ifThenElse _ _ _ _ = ()
+
+y :: ()
+y = if 'a' then () else ()
diff --git a/testsuite/tests/rebindable/rebindable12.stderr b/testsuite/tests/rebindable/rebindable12.stderr
new file mode 100644
index 0000000000..e6c97e95f6
--- /dev/null
+++ b/testsuite/tests/rebindable/rebindable12.stderr
@@ -0,0 +1,5 @@
+
+rebindable12.hs:10:5:
+     Couldn't match expected type ‘()’ with actual type ‘() -> ()’
+     In the expression: if 'a' then () else ()
+      In an equation for ‘y’: y = if 'a' then () else ()
diff --git a/testsuite/tests/th/T18102.hs b/testsuite/tests/th/T18102.hs
new file mode 100644
index 0000000000..c1dad776da
--- /dev/null
+++ b/testsuite/tests/th/T18102.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell, RebindableSyntax #-}
+
+module Bug where
+
+import Prelude ( Monad(..), Bool(..), print, ($) )
+import Language.Haskell.TH.Syntax
+
+$( do _stuff <- [| if True then 10 else 15 |]
+      return [] )
+
+$$( do _stuff <- [|| if True then 10 else 15 ||]
+       return [] )
diff --git a/testsuite/tests/th/T18102.stderr b/testsuite/tests/th/T18102.stderr
new file mode 100644
index 0000000000..9c1f1e2484
--- /dev/null
+++ b/testsuite/tests/th/T18102.stderr
@@ -0,0 +1,25 @@
+
+T18102.hs:11:22: error:
+    • Not in scope: ‘ifThenElse’
+    • In the Template Haskell quotation [|| if True then 10 else 15 ||]
+      In the typed splice:
+        $$(do _stuff <- [|| if True then 10 else 15 ||]
+              return [])
+
+T18102.hs:11:35: error:
+    • Not in scope: ‘fromInteger’
+      Perhaps you want to add ‘fromInteger’ to the import list
+      in the import of ‘Prelude’ (T18102.hs:5:1-50).
+    • In the Template Haskell quotation [|| if True then 10 else 15 ||]
+      In the typed splice:
+        $$(do _stuff <- [|| if True then 10 else 15 ||]
+              return [])
+
+T18102.hs:11:43: error:
+    • Not in scope: ‘fromInteger’
+      Perhaps you want to add ‘fromInteger’ to the import list
+      in the import of ‘Prelude’ (T18102.hs:5:1-50).
+    • In the Template Haskell quotation [|| if True then 10 else 15 ||]
+      In the typed splice:
+        $$(do _stuff <- [|| if True then 10 else 15 ||]
+              return [])
diff --git a/testsuite/tests/th/T18102b.hs b/testsuite/tests/th/T18102b.hs
new file mode 100644
index 0000000000..0f686291de
--- /dev/null
+++ b/testsuite/tests/th/T18102b.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import T18102b_aux
+
+x :: Int
+x = $$(intQuote)
+
+main :: IO ()
+main = print x
diff --git a/testsuite/tests/th/T18102b.stdout b/testsuite/tests/th/T18102b.stdout
new file mode 100644
index 0000000000..410b14d2ce
--- /dev/null
+++ b/testsuite/tests/th/T18102b.stdout
@@ -0,0 +1 @@
+25
\ No newline at end of file
diff --git a/testsuite/tests/th/T18102b_aux.hs b/testsuite/tests/th/T18102b_aux.hs
new file mode 100644
index 0000000000..f6badf02d7
--- /dev/null
+++ b/testsuite/tests/th/T18102b_aux.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE RebindableSyntax, TemplateHaskell #-}
+module T18102b_aux where
+
+import Prelude
+import Language.Haskell.TH.Syntax
+
+ifThenElse :: Bool -> Int -> Int -> Int
+ifThenElse _ a b = a+b
+
+intQuote :: Q (TExp Int)
+intQuote = [|| if True then 10 else 15 ||]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 24cc9d9b46..6d4a5036d7 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -508,6 +508,8 @@ test('T18097', normal, compile, [''])
 test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])
 test('TH_StringLift', normal, compile, [''])
 test('TH_BytesShowEqOrd', normal, compile_and_run, [''])
+test('T18102', normal, compile_fail, [''])
+test('T18102b', extra_files(['T18102b_aux.hs']), compile_and_run, [''])
 test('T18121', normal, compile, [''])
 test('T18123', normal, compile, [''])
 test('T18388', normal, compile, [''])