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.

3 files changed, 205 insertions, 32 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 9f5e6a7ef2..b2c808519e 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -382,9 +382,6 @@ data HsExpr p
   -- For details on above see note [Api annotations] in GHC.Parser.Annotation
   | HsIf        (XIf p)        -- GhcPs: this is a Bool; False <=> do not use
                                --  rebindable syntax
-                (SyntaxExpr p) -- cond function
-                                 -- NoSyntaxExpr => use the built-in 'if'
-                                 -- See Note [Rebindable if]
                 (LHsExpr p)    --  predicate
                 (LHsExpr p)    --  then part
                 (LHsExpr p)    --  else part
@@ -557,8 +554,10 @@ data HsExpr p
   -- Expressions annotated with pragmas, written as {-# ... #-}
   | HsPragE (XPragE p) (HsPragE p) (LHsExpr p)
 
-  | XExpr       !(XXExpr p) -- Note [Trees that Grow] extension constructor
-
+  | XExpr       !(XXExpr p)
+  -- Note [Trees that Grow] extension constructor for the
+  -- general idea, and Note [Rebindable syntax and HsExpansion]
+  -- for an example of how we use it.
 
 -- | Extra data fields for a 'RecordCon', added by the type checker
 data RecordConTc = RecordConTc
@@ -624,9 +623,7 @@ type instance XExplicitSum   GhcTc = [Type]
 
 type instance XCase          (GhcPass _) = NoExtField
 
-type instance XIf            GhcPs = Bool      -- True <=> might use rebindable syntax
-type instance XIf            GhcRn = NoExtField
-type instance XIf            GhcTc = NoExtField
+type instance XIf            (GhcPass _) = NoExtField
 
 type instance XMultiIf       GhcPs = NoExtField
 type instance XMultiIf       GhcRn = NoExtField
@@ -674,8 +671,155 @@ type instance XBinTick       (GhcPass _) = NoExtField
 type instance XPragE         (GhcPass _) = NoExtField
 
 type instance XXExpr         GhcPs       = NoExtCon
-type instance XXExpr         GhcRn       = NoExtCon
-type instance XXExpr         GhcTc       = HsWrap HsExpr
+
+-- See Note [Rebindable syntax and HsExpansion] below
+type instance XXExpr         GhcRn       = HsExpansion (HsExpr GhcRn)
+                                                       (HsExpr GhcRn)
+type instance XXExpr         GhcTc       = XXExprGhcTc
+
+data XXExprGhcTc
+  = WrapExpr {-# UNPACK #-} !(HsWrap HsExpr)
+  | ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))
+
+
+{-
+Note [Rebindable syntax and HsExpansion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We implement rebindable syntax (RS) support by performing a desugaring
+in the renamer. We transform GhcPs expressions affected by RS into the
+appropriate desugared form, but **annotated with the original expression**.
+
+Let us consider a piece of code like:
+
+    {-# LANGUAGE RebindableSyntax #-}
+    ifThenElse :: Char -> () -> () -> ()
+    ifThenElse _ _ _ = ()
+    x = if 'a' then () else True
+
+The parsed AST for the RHS of x would look something like (slightly simplified):
+
+    L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))
+
+Upon seeing such an AST with RS on, we could transform it into a
+mere function call, as per the RS rules, equivalent to the
+following function application:
+
+    ifThenElse 'a' () True
+
+which doesn't typecheck. But GHC would report an error about
+not being able to match the third argument's type (Bool) with the
+expected type: (), in the expression _as desugared_, i.e in
+the aforementioned function application. But the user never
+wrote a function application! This would be pretty bad.
+
+To remedy this, instead of transforming the original HsIf
+node into mere applications of 'ifThenElse', we keep the
+original 'if' expression around too, using the TTG
+XExpr extension point to allow GHC to construct an
+'HsExpansion' value that will keep track of the original
+expression in its first field, and the desugared one in the
+second field. The resulting renamed AST would look like:
+
+    L locif (XExpr
+      (HsExpanded
+        (HsIf (L loca 'a')
+              (L loctrue ())
+              (L locfalse True)
+        )
+        (App (L generatedSrcSpan
+                (App (L generatedSrcSpan
+                        (App (L generatedSrcSpan (Var ifThenElse))
+                             (L loca 'a')
+                        )
+                     )
+                     (L loctrue ())
+                )
+             )
+             (L locfalse True)
+        )
+      )
+    )
+
+When comes the time to typecheck the program, we end up calling
+tcMonoExpr on the AST above. If this expression gives rise to
+a type error, then it will appear in a context line and GHC
+will pretty-print it using the 'Outputable (HsExpansion a b)'
+instance defined below, which *only prints the original
+expression*. This is the gist of the idea, but is not quite
+enough to recover the error messages that we had with the
+SyntaxExpr-based, typechecking/desugaring-to-core time
+implementation of rebindable syntax. The key idea is to decorate
+some elements of the desugared expression so as to be able to
+give them a special treatment when typechecking the desugared
+expression, to print a different context line or skip one
+altogether.
+
+Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in
+TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we
+entered generated code, i.e code fabricated by the compiler when rebinding some
+syntax. If someone tries to push some error context line while that field is set
+to True, the pushing won't actually happen and the context line is just dropped.
+Once we 'setSrcSpan' a real span (for an expression that was in the original
+source code), we set 'tcl_in_gen_code' back to False, indicating that we
+"emerged from the generated code tunnel", and that the expressions we will be
+processing are relevant to report in context lines again.
+
+You might wonder why we store a RealSrcSpan in addition to a Bool in
+the TcLclEnv: could we not store a Maybe RealSrcSpan? The problem is
+that we still generate constraints when processing generated code,
+and a CtLoc must contain a RealSrcSpan -- otherwise, error messages
+might appear without source locations. So we keep the RealSrcSpan of
+the last location spotted that wasn't generated; it's as good as
+we're going to get in generated code. Once we get to sub-trees that
+are not generated, then we update the RealSrcSpan appropriately, and
+set the tcl_in_gen_code Bool to False.
+
+---
+
+A general recipe to follow this approach for new constructs could go as follows:
+
+- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your
+  construct, in HsExpr or related syntax data types.
+- At renaming-time:
+    - take your original node of interest (HsIf above)
+    - rename its subexpressions (condition, true branch, false branch above)
+    - construct the suitable "rebound"-and-renamed result (ifThenElse call
+      above), where the 'SrcSpan' attached to any _fabricated node_ (the
+      HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'
+    - take both the original node and that rebound-and-renamed result and wrap
+      them in an XExpr: XExpr (HsExpanded <original node> <desugared>)
+ - At typechecking-time:
+    - remove any logic that was previously dealing with your rebindable
+      construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.
+    - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we
+      typecheck the desugared expression while reporting the original one in
+      errors
+
+-}
+
+-- See Note [Rebindable syntax and HsExpansion] just above.
+data HsExpansion a b
+  = HsExpanded a b
+  deriving Data
+
+-- | Build a "wrapped" 'HsExpansion' out of an extension constructor,
+--   and the two components of the expansion: original and desugared
+--   expressions.
+--
+--   See Note [Rebindable Syntax and HsExpansion] above for more details.
+mkExpanded
+  :: (HsExpansion a b -> b) -- ^ XExpr, XCmd, ...
+  -> a                      -- ^ source expression ('GhcPs')
+  -> b                      -- ^ "desugared" expression
+                            --   ('GhcRn')
+  -> b                      -- ^ suitably wrapped
+                            --   'HsExpansion'
+mkExpanded xwrap a b = xwrap (HsExpanded a b)
+
+-- | Just print the original expression (the @a@).
+instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
+  ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
 
 -- ---------------------------------------------------------------------
 
@@ -1020,7 +1164,7 @@ ppr_expr (HsCase _ expr matches)
   = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],
           nest 2 (pprMatches matches) ]
 
-ppr_expr (HsIf _ _ e1 e2 e3)
+ppr_expr (HsIf _ e1 e2 e3)
   = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],
          nest 4 (ppr e2),
          text "else",
@@ -1092,21 +1236,25 @@ ppr_expr (HsRecFld _ f) = ppr f
 ppr_expr (XExpr x) = case ghcPass @p of
 #if __GLASGOW_HASKELL__ < 811
   GhcPs -> ppr x
-  GhcRn -> ppr x
 #endif
+  GhcRn -> ppr x
   GhcTc -> case x of
-    HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e
-                                                      else pprExpr e)
+    WrapExpr (HsWrap co_fn e) -> pprHsWrapper co_fn
+      (\parens -> if parens then pprExpr e else pprExpr e)
+    ExpansionExpr e -> ppr e -- e is an HsExpansion, we print the original
+                             -- expression (LHsExpr GhcPs), not the
+                             -- desugared one (LHsExpr GhcT).
 
 ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
 ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)
 ppr_infix_expr (HsConLikeOut _ c)   = Just (pprInfixOcc (conLikeName c))
 ppr_infix_expr (HsRecFld _ f)       = Just (pprInfixOcc f)
 ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)
-ppr_infix_expr (XExpr x)
-  | GhcTc <- ghcPass @p
-  , HsWrap _ e <- x
-  = ppr_infix_expr e
+ppr_infix_expr (XExpr x)            = case (ghcPass @p, x) of
+  (GhcPs, _)                              -> Nothing
+  (GhcRn, HsExpanded a _)                 -> ppr_infix_expr a
+  (GhcTc, WrapExpr (HsWrap _ e))          -> ppr_infix_expr e
+  (GhcTc, ExpansionExpr (HsExpanded a _)) -> ppr_infix_expr a
 ppr_infix_expr _ = Nothing
 
 ppr_apps :: (OutputableBndrId p)
@@ -1207,9 +1355,11 @@ hsExprNeedsParens p = go
     go (HsRecFld{})                   = False
     go (XExpr x)
       | GhcTc <- ghcPass @p
-      , HsWrap _ e <- x
-      = go e
-
+      = case x of
+          WrapExpr      (HsWrap _ e)     -> go e
+          ExpansionExpr (HsExpanded a _) -> hsExprNeedsParens p a
+      | GhcRn <- ghcPass @p
+      = case x of HsExpanded a _ -> hsExprNeedsParens p a
       | otherwise
       = True
 
@@ -1241,8 +1391,11 @@ isAtomicHsExpr (HsUnboundVar {}) = True
 isAtomicHsExpr (HsPar _ e)       = isAtomicHsExpr (unLoc e)
 isAtomicHsExpr (HsRecFld{})      = True
 isAtomicHsExpr (XExpr x)
-  | GhcTc <- ghcPass @p
-  , HsWrap _ e <- x              = isAtomicHsExpr e
+  | GhcTc <- ghcPass @p          = case x of
+      WrapExpr      (HsWrap _ e)     -> isAtomicHsExpr e
+      ExpansionExpr (HsExpanded a _) -> isAtomicHsExpr a
+  | GhcRn <- ghcPass @p          = case x of
+      HsExpanded a _         -> isAtomicHsExpr a
 isAtomicHsExpr _                 = False
 
 instance Outputable (HsPragE (GhcPass p)) where
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 87ded0d22d..d46f9d7986 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -468,4 +468,7 @@ deriving instance Eq (IE GhcPs)
 deriving instance Eq (IE GhcRn)
 deriving instance Eq (IE GhcTc)
 
+
 -- ---------------------------------------------------------------------
+
+deriving instance Data XXExprGhcTc
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 626a771be7..3e37e7b388 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -33,7 +33,8 @@ just attach noSrcSpan to everything.
 
 module GHC.Hs.Utils(
   -- * Terms
-  mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
+  mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,
+  mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS,
   mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
@@ -189,7 +190,25 @@ mkLocatedList [] = noLoc []
 mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
 
 mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2)
+mkHsApp = mkHsAppWith addCLoc
+
+mkHsAppWith
+  :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))
+  -> LHsExpr (GhcPass id)
+  -> LHsExpr (GhcPass id)
+  -> LHsExpr (GhcPass id)
+mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2)
+
+mkHsApps
+  :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
+mkHsApps = mkHsAppsWith addCLoc
+
+mkHsAppsWith
+ :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))
+ -> LHsExpr (GhcPass id)
+ -> [LHsExpr (GhcPass id)]
+ -> LHsExpr (GhcPass id)
+mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated)
 
 mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn
 mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct)
@@ -291,8 +310,7 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
 
 -- restricted to GhcPs because other phases might need a SyntaxExpr
 mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
-mkHsIf c a b = HsIf True {- this might use rebindable syntax -} noSyntaxExpr c a b
-  -- see Note [Rebindable if] in "GHC.Hs.Expr"
+mkHsIf c a b = HsIf noExtField c a b
 
 -- restricted to GhcPs because other phases might need a SyntaxExpr
 mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs
@@ -508,9 +526,8 @@ nlHsPar e              = noLoc (HsPar noExtField e)
 
 -- nlHsIf should generate if-expressions which are NOT subject to
 -- RebindableSyntax, so the first field of HsIf is False. (#12080)
--- See Note [Rebindable if] in "GHC.Hs.Expr"
 nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-nlHsIf cond true false = noLoc (HsIf False noSyntaxExpr cond true false)
+nlHsIf cond true false = noLoc (HsIf noExtField cond true false)
 
 nlHsCase expr matches
   = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches))
@@ -690,9 +707,9 @@ mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 -- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr"
 mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
 mkHsWrap co_fn e | isIdHsWrapper co_fn   = e
-mkHsWrap co_fn (XExpr (HsWrap co_fn' e)) = mkHsWrap (co_fn <.> co_fn') e
-mkHsWrap co_fn (HsPar x (L l e))         = HsPar x (L l (mkHsWrap co_fn e))
-mkHsWrap co_fn e                         = XExpr (HsWrap co_fn e)
+mkHsWrap co_fn (XExpr (WrapExpr (HsWrap co_fn' e))) = mkHsWrap (co_fn <.> co_fn') e
+mkHsWrap co_fn (HsPar x (L l e))                = HsPar x (L l (mkHsWrap co_fn e))
+mkHsWrap co_fn e                                = XExpr (WrapExpr $ HsWrap co_fn e)
 
 mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b
            -> HsExpr GhcTc -> HsExpr GhcTc