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.

20 files changed, 529 insertions, 122 deletions

diff --git a/compiler/GHC/Builtin/RebindableNames.hs b/compiler/GHC/Builtin/RebindableNames.hs
new file mode 100644
index 0000000000..0a07224b15
--- /dev/null
+++ b/compiler/GHC/Builtin/RebindableNames.hs
@@ -0,0 +1,6 @@
+module GHC.Builtin.RebindableNames where
+
+import GHC.Data.FastString
+
+reboundIfSymbol :: FastString
+reboundIfSymbol = fsLit "ifThenElse"
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
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 7451d0113d..edd67e5b17 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -552,8 +552,8 @@ addTickHsExpr (HsCase x e mgs) =
                 (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
                                    -- be evaluated.
                 (addTickMatchGroup False mgs)
-addTickHsExpr (HsIf x cnd e1 e2 e3) =
-        liftM3 (HsIf x cnd)
+addTickHsExpr (HsIf x e1 e2 e3) =
+        liftM3 (HsIf x)
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
                 (addTickLHsExprOptAlt True e2)
                 (addTickLHsExprOptAlt True e3)
@@ -629,10 +629,12 @@ addTickHsExpr (HsProc x pat cmdtop) =
         liftM2 (HsProc x)
                 (addTickLPat pat)
                 (liftL (addTickHsCmdTop) cmdtop)
-addTickHsExpr (XExpr (HsWrap w e)) =
-        liftM XExpr $
-        liftM (HsWrap w)
+addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =
+        liftM (XExpr . WrapExpr . HsWrap w) $
               (addTickHsExpr e)        -- Explicitly no tick on inside
+addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =
+        liftM (XExpr . ExpansionExpr . HsExpanded a) $
+              (addTickHsExpr b)
 
 -- Others should never happen in expression content.
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 696cebe565..7ac72bad55 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -276,12 +276,12 @@ dsExpr (HsLit _ lit)
 dsExpr (HsOverLit _ lit)
   = do { warnAboutOverflowedOverLit lit
        ; dsOverLit lit }
-
-dsExpr hswrap@(XExpr (HsWrap co_fn e))
+dsExpr (XExpr (ExpansionExpr (HsExpanded _ b))) = dsExpr b
+dsExpr hswrap@(XExpr (WrapExpr (HsWrap co_fn e)))
   = do { e' <- case e of
                  HsVar _ (L _ var) -> return $ varToCoreExpr var
                  HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc)
-                 XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap)
+                 XExpr (WrapExpr (HsWrap _ _)) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap)
                  HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap)
                  _ -> addTyCsDs FromSource (hsWrapDictBinders co_fn) $
                       dsExpr e
@@ -474,13 +474,11 @@ dsExpr (HsDo _ ctx@GhciStmtCtxt  (L _ stmts)) = dsDo ctx stmts
 dsExpr (HsDo _ ctx@MDoExpr{}     (L _ stmts)) = dsDo ctx stmts
 dsExpr (HsDo _ MonadComp     (L _ stmts)) = dsMonadComp stmts
 
-dsExpr (HsIf _ fun guard_expr then_expr else_expr)
+dsExpr (HsIf _ guard_expr then_expr else_expr)
   = do { pred <- dsLExpr guard_expr
        ; b1 <- dsLExpr then_expr
        ; b2 <- dsLExpr else_expr
-       ; case fun of  -- See Note [Rebindable if] in "GHC.Hs.Expr"
-           (SyntaxExprTc {}) -> dsSyntaxExpr fun [pred, b1, b2]
-           NoSyntaxExprTc    -> return $ mkIfThenElse pred b1 b2 }
+       ; return $ mkIfThenElse pred b1 b2 }
 
 dsExpr (HsMultiIf res_ty alts)
   | null alts
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 6bff5e826f..5dc7328879 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -1056,7 +1056,10 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     exp e (HsPar _ (L _ e'))   = exp e e'
     -- because the expressions do not necessarily have the same type,
     -- we have to compare the wrappers
-    exp (XExpr (HsWrap h e)) (XExpr (HsWrap  h' e')) = wrap h h' && exp e e'
+    exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap  h' e'))) =
+      wrap h h' && exp e e'
+    exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) =
+      exp b b'
     exp (HsVar _ i) (HsVar _ i') =  i == i'
     exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
     -- the instance for IPName derives using the id, so this works if the
@@ -1084,7 +1087,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
         eq_list tup_arg es1 es2
     exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
-    exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
+    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
         lexp e e' && lexp e1 e1' && lexp e2 e2'
 
     -- Enhancement: could implement equality for more expressions
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index cdea4a6ff5..bbe56af5b7 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1474,11 +1474,11 @@ repE (HsCase _ e (MG { mg_alts = (L _ ms) }))
                                ; ms2 <- mapM repMatchTup ms
                                ; core_ms2 <- coreListM matchTyConName ms2
                                ; repCaseE arg core_ms2 }
-repE (HsIf _ _ x y z)       = do
-                              a <- repLE x
-                              b <- repLE y
-                              c <- repLE z
-                              repCond a b c
+repE (HsIf _ x y z)       = do
+                            a <- repLE x
+                            b <- repLE y
+                            c <- repLE z
+                            repCond a b c
 repE (HsMultiIf _ alts)
   = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
        ; expr' <- repMultiIf (nonEmptyCoreList alts')
@@ -1569,7 +1569,7 @@ repE (HsUnboundVar _ uv)   = do
                                occ   <- occNameLit uv
                                sname <- repNameS occ
                                repUnboundVar sname
-
+repE (XExpr (HsExpanded _ b))        = repE b
 repE e@(HsPragE _ HsPragCore {} _)   = notHandled "Core annotations" (ppr e)
 repE e@(HsPragE _ HsPragSCC  {} _)   = notHandled "Cost centres" (ppr e)
 repE e@(HsPragE _ HsPragTick {} _)   = notHandled "Tick Pragma" (ppr e)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 7c9c37efe2..6325b722e9 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -758,14 +758,14 @@ instance HiePass p => HasType (LHsExpr (GhcPass p)) where
           -- performance before marking more things as 'True'.
           skipDesugaring :: HsExpr GhcTc -> Bool
           skipDesugaring e = case e of
-            HsVar{}          -> False
-            HsUnboundVar{}   -> False
-            HsConLikeOut{}   -> False
-            HsRecFld{}       -> False
-            HsOverLabel{}    -> False
-            HsIPVar{}        -> False
-            XExpr (HsWrap{}) -> False
-            _                -> True
+            HsVar{}             -> False
+            HsUnboundVar{}      -> False
+            HsConLikeOut{}      -> False
+            HsRecFld{}          -> False
+            HsOverLabel{}       -> False
+            HsIPVar{}           -> False
+            XExpr (WrapExpr {}) -> False
+            _                   -> True
 
 data HiePassEv p where
   HieRn :: HiePassEv 'Renamed
@@ -1099,7 +1099,7 @@ instance HiePass p => ToHie (LHsExpr (GhcPass p)) where
         [ toHie expr
         , toHie matches
         ]
-      HsIf _ _ a b c ->
+      HsIf _ a b c ->
         [ toHie a
         , toHie b
         , toHie c
@@ -1166,10 +1166,14 @@ instance HiePass p => ToHie (LHsExpr (GhcPass p)) where
         ]
       XExpr x
         | GhcTc <- ghcPass @p
-        , HsWrap w a <- x
+        , WrapExpr (HsWrap w a) <- x
         -> [ toHie $ L mspan a
            , toHie (L mspan w)
            ]
+        | GhcTc <- ghcPass @p
+        , ExpansionExpr (HsExpanded _ b) <- x
+        -> [ toHie (L mspan b)
+           ]
         | otherwise -> []
 
 instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index e425fd9457..2b0a2e5ae9 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -31,7 +31,7 @@ module GHC.Rename.Env (
 
         -- Rebindable Syntax
         lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames,
-        lookupIfThenElse,
+        lookupIfThenElse, lookupReboundIf,
 
         -- QualifiedDo
         lookupQualifiedDoExpr, lookupQualifiedDo,
@@ -58,6 +58,7 @@ import GHC.Driver.Types
 import GHC.Tc.Utils.Env
 import GHC.Tc.Utils.Monad
 import GHC.Parser.PostProcess ( filterCTuple, setRdrNameSpace )
+import GHC.Builtin.RebindableNames
 import GHC.Builtin.Types
 import GHC.Types.Name
 import GHC.Types.Name.Set
@@ -1770,6 +1771,32 @@ lookupQualifiedDoName ctxt std_name
       Nothing -> lookupSyntaxName std_name
       Just modName -> lookupNameWithQualifier std_name modName
 
+
+-- Lookup a locally-rebound name for Rebindable Syntax (RS).
+--
+-- - When RS is off, 'lookupRebound' just returns 'Nothing', whatever
+--   name it is given.
+--
+-- - When RS is on, we always try to return a 'Just', and GHC errors out
+--   if no suitable name is found in the environment.
+--
+-- 'Nothing' really is "reserved" and means that rebindable syntax is off.
+lookupRebound :: FastString -> RnM (Maybe (Located Name))
+lookupRebound nameStr = do
+  rebind <- xoptM LangExt.RebindableSyntax
+  if rebind
+    -- If repetitive lookups ever become a problem perormance-wise,
+    -- we could lookup all the names we will ever care about just once
+    -- at the beginning and stick them in the environment, possibly
+    -- populating that "cache" lazily too.
+    then (\nm -> Just (L (nameSrcSpan nm) nm)) <$>
+         lookupOccRn (mkVarUnqual nameStr)
+    else pure Nothing
+
+-- | Lookup an @ifThenElse@ binding (see 'lookupRebound').
+lookupReboundIf :: RnM (Maybe (Located Name))
+lookupReboundIf = lookupRebound reboundIfSymbol
+
 -- Error messages
 
 
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 2bfba1fb7f..35dfb6b282 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -322,14 +322,21 @@ rnExpr (ExprWithTySig _ expr pty)
         ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
                              rnLExpr expr
         ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }
-
-rnExpr (HsIf might_use_rebindable_syntax _ p b1 b2)
+rnExpr (HsIf _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
        ; (b1', fvB1) <- rnLExpr b1
        ; (b2', fvB2) <- rnLExpr b2
-       ; (mb_ite, fvITE) <- lookupIfThenElse might_use_rebindable_syntax
-       ; return (HsIf noExtField mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
-
+       ; mifteName <- lookupReboundIf
+       ; let subFVs = plusFVs [fvP, fvB1, fvB2]
+       ; return $ case mifteName of
+           -- RS is off, we keep an 'HsIf' node around
+           Nothing ->
+             (HsIf noExtField  p' b1' b2', subFVs)
+           -- See Note [Rebindable syntax and HsExpansion].
+           Just ifteName ->
+             let ifteExpr = rebindIf ifteName p' b1' b2'
+             in (ifteExpr, plusFVs [unitFV (unLoc ifteName), subFVs])
+       }
 rnExpr (HsMultiIf x alts)
   = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
        -- ; return (HsMultiIf ty alts', fvs) }
@@ -2224,3 +2231,26 @@ getMonadFailOp ctxt
               mkSyntaxExpr failAfterFromStringExpr
         return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
       | otherwise = lookupQualifiedDo ctxt failMName
+
+-- Rebinding 'if's to 'ifThenElse' applications.
+--
+-- See Note [Rebindable syntax and HsExpansion]
+rebindIf
+  :: Located Name  -- 'Name' for the 'ifThenElse' function we will rebind to
+  -> LHsExpr GhcRn -- renamed condition
+  -> LHsExpr GhcRn -- renamed true branch
+  -> LHsExpr GhcRn -- renamed false branch
+  -> HsExpr GhcRn  -- rebound if expression
+rebindIf ifteName p b1 b2 =
+  let ifteOrig = HsIf noExtField p b1 b2
+      ifteFun  = L generatedSrcSpan (HsVar noExtField ifteName)
+                 -- ifThenElse var
+      ifteApp  = mkHsAppsWith (\_ _ e -> L generatedSrcSpan e)
+                              ifteFun
+                              [p, b1, b2]
+                 -- desugared_if_expr =
+                 --   ifThenElse desugared_predicate
+                 --              desugared_true_branch
+                 --              desugared_false_branch
+  in mkExpanded XExpr ifteOrig (unLoc ifteApp)
+     -- (source_if_expr, desugared_if_expr)
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 48a663952a..e49ff87db2 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -111,6 +111,8 @@ rnBracket e br_body
             False -> do { traceRn "Renaming untyped TH bracket" empty
                         ; ps_var <- newMutVar []
                         ; (body', fvs_e) <-
+                          -- See Note [Rebindable syntax and Template Haskell]
+                          unsetXOptM LangExt.RebindableSyntax $
                           setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
                                    rn_bracket cur_stage br_body
                         ; pendings <- readMutVar ps_var
@@ -492,6 +494,67 @@ to try and
 
 -}
 
+{- Note [Rebindable syntax and Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When processing Template Haskell quotes with Rebindable Syntax (RS) enabled,
+there are two possibilities: apply the RS rules to the quotes or don't.
+
+One might expect that with {-# LANGUAGE RebindableSyntax #-} at the top of a
+module, any 'if' expression would end up being turned into a call to whatever
+'ifThenElse' function is in scope, regardless of whether the said if expression
+appears in "normal" Haskell code or in a TH quote. This however comes with its
+problems. Consider the following code:
+
+  {-# LANGUAGE TemplateHaskell, RebindableSyntax #-}
+
+  module X where
+
+  import Prelude ( Monad(..), Bool(..), print, ($) )
+  import Language.Haskell.TH.Syntax
+
+  $( do stuff <- [| if True then 10 else 15 |]
+        runIO $ print stuff
+        return [] )
+
+If we apply the RS rules, then GHC would complain about not having suitable
+fromInteger/ifThenElse functions in scope. But this quote is just a bit of
+Haskell syntax that has yet to be used, or, to put it differently, placed
+(spliced) in some context where the said functions might be available. More
+generally, untyped TH quotes are meant to work with yet-unbound identifiers.
+This tends to show that untyped TH and Rebindable Syntax overall don't play
+well together. Users still have the option to splice "normal" if expressions
+into modules where RS is enabled, to turn them into applications of
+an 'ifThenElse' function of their choice.
+
+Typed TH (TTH) quotes, on the other hand, come with different constraints. They
+don't quite have this "delayed" nature: we typecheck them while processing
+them, and TTH users expect RS to Just Work in their quotes, exactly like it does
+outside of the quotes. There, we do not have to accept unbound identifiers and
+we can apply the RS rules both in the typechecking and desugaring of the quotes
+without triggering surprising/bad behaviour for users. For instance, the
+following code is expected to be rejected (because of the lack of suitable
+'fromInteger'/'ifThenElse' functions in scope):
+
+  {-# LANGUAGE TemplateHaskell, RebindableSyntax #-}
+
+  module X where
+
+  import Prelude ( Monad(..), Bool(..), print, ($) )
+  import Language.Haskell.TH.Syntax
+
+  $$( do stuff <- [|| if True then 10 else 15 ||]
+         runIO $ print stuff
+         return [] )
+
+The conclusion is that even if RS is enabled for a given module, GHC disables it
+when processing untyped TH quotes from that module, to avoid the aforementioned
+problems, but keeps it on while processing typed TH quotes.
+
+This note and approach originated in #18102.
+
+-}
+
 {- Note [Delaying modFinalizers in untyped splices]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index eaf3a3db0c..d5ecbcbe45 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -123,12 +123,20 @@ tcPolyExpr expr res_ty
        ; tcPolyExprNC expr res_ty }
 
 tcPolyExprNC (L loc expr) res_ty
-  = setSrcSpan loc $
+  = set_loc_and_ctxt loc expr $
     do { traceTc "tcPolyExprNC" (ppr res_ty)
        ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
                           tcExpr expr res_ty
        ; return $ L loc (mkHsWrap wrap expr') }
 
+  where -- See Note [Rebindable syntax and HsExpansion), which describes
+        -- the logic behind this location/context tweaking.
+        set_loc_and_ctxt l e m = do
+          inGenCode <- inGeneratedCode
+          if inGenCode && not (isGeneratedSrcSpan l)
+            then setSrcSpan l $ addExprCtxt (L l e) m
+            else setSrcSpan l m
+
 ---------------
 tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)
 -- Used by tcRnExpr to implement GHCi :type
@@ -188,7 +196,7 @@ tcLExpr, tcLExprNC
     -> TcM (LHsExpr GhcTc)
 
 tcLExpr expr res_ty
-  = addExprCtxt expr (tcLExprNC expr res_ty)
+  = setSrcSpan (getLoc expr) $ addExprCtxt expr (tcLExprNC expr res_ty)
 
 tcLExprNC (L loc expr) res_ty
   = setSrcSpan loc $
@@ -589,26 +597,15 @@ tcExpr (HsCase x scrut matches) res_ty
     match_ctxt = MC { mc_what = CaseAlt,
                       mc_body = tcBody }
 
-tcExpr (HsIf x NoSyntaxExprRn pred b1 b2) res_ty    -- Ordinary 'if'
+tcExpr (HsIf x pred b1 b2) res_ty
   = do { pred' <- tcLExpr pred (mkCheckExpType boolTy)
        ; res_ty <- tauifyExpType res_ty
            -- Just like Note [Case branches must never infer a non-tau type]
            -- in GHC.Tc.Gen.Match (See #10619)
-
        ; (u1,b1') <- tcCollectingUsage $ tcLExpr b1 res_ty
        ; (u2,b2') <- tcCollectingUsage $ tcLExpr b2 res_ty
        ; tcEmitBindingUsage (supUE u1 u2)
-       ; return (HsIf x NoSyntaxExprTc pred' b1' b2') }
-
-tcExpr (HsIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty
-  = do { ((pred', b1', b2'), fun')
-           <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
-              \ [pred_ty, b1_ty, b2_ty] [pred_mult, b1_mult, b2_mult] ->
-              do { pred' <- tcScalingUsage pred_mult $ tcCheckPolyExpr pred pred_ty
-                 ; b1'   <- tcScalingUsage b1_mult   $ tcCheckPolyExpr b1   b1_ty
-                 ; b2'   <- tcScalingUsage b2_mult   $ tcCheckPolyExpr b2   b2_ty
-                 ; return (pred', b1', b2') }
-       ; return (HsIf x fun' pred' b1' b2') }
+       ; return (HsIf x pred' b1' b2') }
 
 tcExpr (HsMultiIf _ alts) res_ty
   = do { res_ty <- if isSingleton alts
@@ -1063,6 +1060,19 @@ tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty
 {-
 ************************************************************************
 *                                                                      *
+                Rebindable syntax
+*                                                                      *
+************************************************************************
+-}
+
+-- See Note [Rebindable syntax and HsExpansion].
+tcExpr (XExpr (HsExpanded a b)) t
+  = fmap (XExpr . ExpansionExpr . HsExpanded a) $
+      setSrcSpan generatedSrcSpan (tcExpr b t)
+
+{-
+************************************************************************
+*                                                                      *
                 Catch-all
 *                                                                      *
 ************************************************************************
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index f99f99d1a5..611d89954b 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -754,7 +754,8 @@ data TcLclEnv           -- Changes as we move inside an expression
   = TcLclEnv {
         tcl_loc        :: RealSrcSpan,     -- Source span
         tcl_ctxt       :: [ErrCtxt],       -- Error context, innermost on top
-        tcl_tclvl      :: TcLevel,         -- Birthplace for new unification variables
+        tcl_in_gen_code :: Bool,           -- See Note [Rebindable syntax and HsExpansion]
+        tcl_tclvl      :: TcLevel,
 
         tcl_th_ctxt    :: ThStage,         -- Template Haskell context
         tcl_th_bndrs   :: ThBindEnv,       -- and binder info
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 7dfa5ffd65..f89841de92 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -501,7 +501,6 @@ exprCtOrigin (SectionR _ _ _)     = SectionOrigin
 exprCtOrigin (ExplicitTuple {})   = Shouldn'tHappenOrigin "explicit tuple"
 exprCtOrigin ExplicitSum{}        = Shouldn'tHappenOrigin "explicit sum"
 exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
-exprCtOrigin (HsIf _ (SyntaxExprRn syn) _ _ _) = exprCtOrigin syn
 exprCtOrigin (HsIf {})           = Shouldn'tHappenOrigin "if expression"
 exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs
 exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e
@@ -520,6 +519,7 @@ exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc"
 exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression"
 exprCtOrigin (HsTick _ _ e)           = lexprCtOrigin e
 exprCtOrigin (HsBinTick _ _ _ e)      = lexprCtOrigin e
+exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a
 
 -- | Extract a suitable CtOrigin from a MatchGroup
 matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index c65879a8b4..18cdfdf935 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -59,7 +59,7 @@ module GHC.Tc.Utils.Monad(
   addDependentFiles,
 
   -- * Error management
-  getSrcSpanM, setSrcSpan, addLocM,
+  getSrcSpanM, setSrcSpan, addLocM, inGeneratedCode,
   wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_,
   getErrsVar, setErrsVar,
   addErr,
@@ -82,7 +82,7 @@ module GHC.Tc.Utils.Monad(
 
   -- * Context management for the type checker
   getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
-  addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,
+  addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM,
 
   -- * Error message generation (type checker)
   addErrTc,
@@ -341,7 +341,9 @@ initTcWithGbl hsc_env gbl_env loc do_this
       ; usage_var    <- newIORef zeroUE
       ; let lcl_env = TcLclEnv {
                 tcl_errs       = errs_var,
-                tcl_loc        = loc,     -- Should be over-ridden very soon!
+                tcl_loc        = loc,
+                -- tcl_loc should be over-ridden very soon!
+                tcl_in_gen_code = False,
                 tcl_ctxt       = [],
                 tcl_rdr        = emptyLocalRdrEnv,
                 tcl_th_ctxt    = topStage,
@@ -866,11 +868,19 @@ getSrcSpanM :: TcRn SrcSpan
         -- Avoid clash with Name.getSrcLoc
 getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) }
 
+-- See Note [Rebindable syntax and HsExpansion].
+inGeneratedCode :: TcRn Bool
+inGeneratedCode = tcl_in_gen_code <$> getLclEnv
+
 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-setSrcSpan (RealSrcSpan real_loc _) thing_inside
-    = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
--- Don't overwrite useful info with useless:
-setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
+setSrcSpan (RealSrcSpan loc _) thing_inside =
+  updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })
+            thing_inside
+setSrcSpan loc@(UnhelpfulSpan _) thing_inside
+  -- See Note [Rebindable syntax and HsExpansion].
+  | isGeneratedSrcSpan loc =
+      updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside
+  | otherwise = thing_inside
 
 addLocM :: (a -> TcM b) -> Located a -> TcM b
 addLocM fn (L loc a) = setSrcSpan loc $ fn a
@@ -1037,40 +1047,71 @@ failIfErrsM = ifErrsM failM (return ())
 ************************************************************************
 -}
 
+{- Note [Inlining addErrCtxt]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You will notice a bunch of INLINE pragamas on addErrCtxt and friends.
+The reason is to promote better eta-expansion in client modules.
+Consider
+    \e s. addErrCtxt c (tc_foo x) e s
+It looks as if tc_foo is applied to only two arguments, but if we
+inline addErrCtxt it'll turn into something more like
+    \e s. tc_foo x (munge c e) s
+This is much better because Called Arity analysis can see that tc_foo
+is applied to four arguments.  See #18379 for a concrete example.
+
+This reliance on delicate inlining and Called Arity is not good.
+See #18202 for a more general approach.  But meanwhile, these
+ininings seem unobjectional, and they solve the immediate
+problem. -}
+
 getErrCtxt :: TcM [ErrCtxt]
 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
 
 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
+{-# INLINE setErrCtxt #-}   -- Note [Inlining addErrCtxt]
 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
 
 -- | Add a fixed message to the error context. This message should not
 -- do any tidying.
 addErrCtxt :: MsgDoc -> TcM a -> TcM a
+{-# INLINE addErrCtxt #-}   -- Note [Inlining addErrCtxt]
 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
 
 -- | Add a message to the error context. This message may do tidying.
 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
-addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
+{-# INLINE addErrCtxtM #-}  -- Note [Inlining addErrCtxt]
+addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m
 
 -- | Add a fixed landmark message to the error context. A landmark
 -- message is always sure to be reported, even if there is a lot of
 -- context. It also doesn't count toward the maximum number of contexts
 -- reported.
 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
+{-# INLINE addLandmarkErrCtxt #-}  -- Note [Inlining addErrCtxt]
 addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
 
 -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
 -- and tidying.
 addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
-addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
+{-# INLINE addLandmarkErrCtxtM #-}  -- Note [Inlining addErrCtxt]
+addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m
+
+push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc))
+          -> Bool -> [ErrCtxt] -> [ErrCtxt]
+push_ctxt ctxt in_gen ctxts
+  | in_gen    = ctxts
+  | otherwise = ctxt : ctxts
 
+updCtxt :: (Bool -> [ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
+{-# INLINE updCtxt #-} -- Note [Inlining addErrCtxt]
 -- Helper function for the above
-updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
-updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
-                           env { tcl_ctxt = upd ctxt })
+-- The Bool is true if we are in generated code
+updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt
+                                         , tcl_in_gen_code = in_gen }) ->
+                           env { tcl_ctxt = upd in_gen ctxt })
 
 popErrCtxt :: TcM a -> TcM a
-popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
+popErrCtxt = updCtxt (\ _ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
 
 getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
 getCtLocM origin t_or_k
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index c23d1a9e21..63a46dda14 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -825,12 +825,11 @@ zonkExpr env (HsCase x expr ms)
        new_ms <- zonkMatchGroup env zonkLExpr ms
        return (HsCase x new_expr new_ms)
 
-zonkExpr env (HsIf x fun e1 e2 e3)
-  = do (env1, new_fun) <- zonkSyntaxExpr env fun
-       new_e1 <- zonkLExpr env1 e1
-       new_e2 <- zonkLExpr env1 e2
-       new_e3 <- zonkLExpr env1 e3
-       return (HsIf x new_fun new_e1 new_e2 new_e3)
+zonkExpr env (HsIf x e1 e2 e3)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       new_e3 <- zonkLExpr env e3
+       return (HsIf x new_e1 new_e2 new_e3)
 
 zonkExpr env (HsMultiIf ty alts)
   = do { alts' <- mapM (wrapLocM zonk_alt) alts
@@ -907,10 +906,13 @@ zonkExpr env (HsProc x pat body)
 zonkExpr env (HsStatic fvs expr)
   = HsStatic fvs <$> zonkLExpr env expr
 
-zonkExpr env (XExpr (HsWrap co_fn expr))
+zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr)))
   = do (env1, new_co_fn) <- zonkCoFn env co_fn
        new_expr <- zonkExpr env1 expr
-       return (XExpr (HsWrap new_co_fn new_expr))
+       return (XExpr (WrapExpr (HsWrap new_co_fn new_expr)))
+
+zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b)))
+  = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b
 
 zonkExpr _ e@(HsUnboundVar {})
   = return e
diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs
index 71b74c00d5..00bf00ac2c 100644
--- a/compiler/GHC/Types/SrcLoc.hs
+++ b/compiler/GHC/Types/SrcLoc.hs
@@ -39,10 +39,11 @@ module GHC.Types.SrcLoc (
         -- * SrcSpan
         RealSrcSpan,            -- Abstract
         SrcSpan(..),
+        UnhelpfulSpanReason(..),
 
         -- ** Constructing SrcSpan
         mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
-        noSrcSpan,
+        noSrcSpan, generatedSrcSpan, isGeneratedSrcSpan,
         wiredInSrcSpan,         -- Something wired into the compiler
         interactiveSrcSpan,
         srcLocSpan, realSrcLocSpan,
@@ -53,7 +54,8 @@ module GHC.Types.SrcLoc (
         srcSpanStart, srcSpanEnd,
         realSrcSpanStart, realSrcSpanEnd,
         srcSpanFileName_maybe,
-        pprUserRealSpan,
+        pprUserRealSpan, pprUnhelpfulSpanReason,
+        unhelpfulSpanFS,
 
         -- ** Unsafely deconstructing SrcSpan
         -- These are dubious exports, because they crash on some inputs
@@ -302,12 +304,19 @@ data BufSpan =
 -- or a human-readable description of a location.
 data SrcSpan =
     RealSrcSpan !RealSrcSpan !(Maybe BufSpan)  -- See Note [Why Maybe BufPos]
-  | UnhelpfulSpan !FastString   -- Just a general indication
-                                -- also used to indicate an empty span
+  | UnhelpfulSpan !UnhelpfulSpanReason
 
   deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we
                       -- derive Show for Token
 
+data UnhelpfulSpanReason
+  = UnhelpfulNoLocationInfo
+  | UnhelpfulWiredIn
+  | UnhelpfulInteractive
+  | UnhelpfulGenerated
+  | UnhelpfulOther !FastString
+  deriving (Eq, Show)
+
 {- Note [Why Maybe BufPos]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan).
@@ -344,18 +353,23 @@ instance NFData SrcSpan where
   rnf x = x `seq` ()
 
 -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
-noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
-noSrcSpan          = UnhelpfulSpan (fsLit "<no location info>")
-wiredInSrcSpan     = UnhelpfulSpan (fsLit "<wired into compiler>")
-interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")
+noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
+noSrcSpan          = UnhelpfulSpan UnhelpfulNoLocationInfo
+wiredInSrcSpan     = UnhelpfulSpan UnhelpfulWiredIn
+interactiveSrcSpan = UnhelpfulSpan UnhelpfulInteractive
+generatedSrcSpan   = UnhelpfulSpan UnhelpfulGenerated
+
+isGeneratedSrcSpan :: SrcSpan -> Bool
+isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True
+isGeneratedSrcSpan _                                  = False
 
 -- | Create a "bad" 'SrcSpan' that has not location information
 mkGeneralSrcSpan :: FastString -> SrcSpan
-mkGeneralSrcSpan = UnhelpfulSpan
+mkGeneralSrcSpan = UnhelpfulSpan . UnhelpfulOther
 
 -- | Create a 'SrcSpan' corresponding to a single point
 srcLocSpan :: SrcLoc -> SrcSpan
-srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
+srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str)
 srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb)
 
 realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
@@ -383,8 +397,8 @@ isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)
 
 -- | Create a 'SrcSpan' between two points in a file
 mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
-mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
-mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
+mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan (UnhelpfulOther str)
+mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str)
 mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2)
     = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2)
 
@@ -396,7 +410,8 @@ combineSrcSpans l (UnhelpfulSpan _) = l
 combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2)
   | srcSpanFile span1 == srcSpanFile span2
       = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2)
-  | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>")
+  | otherwise = UnhelpfulSpan $
+      UnhelpfulOther (fsLit "<combineSrcSpans: files differ>")
 
 -- | Combines two 'SrcSpan' into one that spans at least all the characters
 -- within both spans. Assumes the "file" part is the same in both inputs
@@ -488,12 +503,12 @@ srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c
 
 -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
 srcSpanStart :: SrcSpan -> SrcLoc
-srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
+srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r)
 srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b)
 
 -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
 srcSpanEnd :: SrcSpan -> SrcLoc
-srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
+srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r)
 srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b)
 
 realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
@@ -559,6 +574,9 @@ instance Outputable RealSrcSpan where
 instance Outputable SrcSpan where
     ppr span = pprUserSpan True span
 
+instance Outputable UnhelpfulSpanReason where
+    ppr = pprUnhelpfulSpanReason
+
 -- I don't know why there is this style-based difference
 --      = getPprStyle $ \ sty ->
 --        if userStyle sty || debugStyle sty then
@@ -568,8 +586,19 @@ instance Outputable SrcSpan where
 --           UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
 --           RealSrcSpan s -> ppr s
 
+unhelpfulSpanFS :: UnhelpfulSpanReason -> FastString
+unhelpfulSpanFS r = case r of
+  UnhelpfulOther s        -> s
+  UnhelpfulNoLocationInfo -> fsLit "<no location info>"
+  UnhelpfulWiredIn        -> fsLit "<wired into compiler>"
+  UnhelpfulInteractive    -> fsLit "<interactive>"
+  UnhelpfulGenerated      -> fsLit "<generated>"
+
+pprUnhelpfulSpanReason :: UnhelpfulSpanReason -> SDoc
+pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r)
+
 pprUserSpan :: Bool -> SrcSpan -> SDoc
-pprUserSpan _         (UnhelpfulSpan s) = ftext s
+pprUserSpan _         (UnhelpfulSpan r) = pprUnhelpfulSpanReason r
 pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s
 
 pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 5bcc98cff4..d73939c53c 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -1448,6 +1448,23 @@ instance Binary BufSpan where
     end <- get bh
     return (BufSpan start end)
 
+instance Binary UnhelpfulSpanReason where
+  put_ bh r = case r of
+    UnhelpfulNoLocationInfo -> putByte bh 0
+    UnhelpfulWiredIn        -> putByte bh 1
+    UnhelpfulInteractive    -> putByte bh 2
+    UnhelpfulGenerated      -> putByte bh 3
+    UnhelpfulOther fs       -> putByte bh 4 >> put_ bh fs
+
+  get bh = do
+    h <- getByte bh
+    case h of
+      0 -> return UnhelpfulNoLocationInfo
+      1 -> return UnhelpfulWiredIn
+      2 -> return UnhelpfulInteractive
+      3 -> return UnhelpfulGenerated
+      _ -> UnhelpfulOther <$> get bh
+
 instance Binary SrcSpan where
   put_ bh (RealSrcSpan ss sb) = do
           putByte bh 0
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index ce887f6a85..dff5244f08 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -398,6 +398,7 @@ Library
         GHC.Builtin.Names
         GHC.Core.Opt.ConstantFold
         GHC.Builtin.PrimOps
+        GHC.Builtin.RebindableNames
         GHC.Builtin.Types.Prim
         GHC.Builtin.Types
         GHC.Types.CostCentre