Type-checking untyped brackets

When HsExpr GhcTc, the HsBracket constructor should hold a HsBracket
GhcRn, rather than an HsBracket GhcTc.

We make use of the HsBracket p extension constructor (XBracket
(XXBracket p)) to hold an HsBracket GhcRn when the pass is GhcTc

See !4782 https://gitlab.haskell.org/ghc/ghc/-/merge_requests/4782

5 files changed, 47 insertions, 22 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 881b005445..b9c9c12415 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -207,13 +207,9 @@ data HsBracketTc = HsBracketTc
                        -- _typechecked_ splices to be
                        -- pasted back in by the desugarer
 
-type instance XBracket     GhcPs = EpAnn [AddEpAnn]
-type instance XBracket     GhcRn = HsBracketRn
-type instance XBracket     GhcTc = HsBracketTc
-
-type instance HsBracketBody GhcPs = HsBracket GhcPs
-type instance HsBracketBody GhcRn = HsBracket GhcRn
-type instance HsBracketBody GhcTc = HsBracket GhcRn
+type instance XBracket GhcPs = EpAnn [AddEpAnn]
+type instance XBracket GhcRn = HsBracketRn
+type instance XBracket GhcTc = HsBracketTc
 
 -- ---------------------------------------------------------------------
 
@@ -1669,12 +1665,13 @@ bracket code.  So for example
     [| f $(g x) |]
 looks like
 
-    HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x)))
+    HsBracket _ (HsApp (HsVar "f") (HsSpliceE _ (g x)))
 
 which the renamer rewrites to
 
-    HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x)))
-                   [PendingRnSplice UntypedExpSplice sn (g x)]
+    HsBracket
+        (HsBracketRnUnTyped _ [PendingRnSplice UntypedExpSplice sn (g x)])
+        (HsApp (HsVar f) (HsSpliceE sn (g x)))
 
 * The 'sn' is the Name of the splice point, the SplicePointName
 
@@ -1776,6 +1773,29 @@ ppr_splice :: (OutputableBndrId p)
 ppr_splice herald n e trail
     = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail
 
+{-
+Note [Type-checking untyped brackets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we type-check an untyped bracket, the actual bracket (the second argument
+of the HsBracket constructor in HsExpr) is kept in the renaming pass.
+
+Given that
+
+  HsExpr p = ...
+    | HsBracket (XBracket p) (HsBracket p)
+
+When p = GhcPs we should have HsExpr GhcPs and HsBracket GhcPs
+When p = GhcRn we should have HsExpr GhcRn and HsBracket GhcRn
+However, when p = GhcRn we should have HsExpr GhcTc and HsBracket GhcRn
+
+To work around this, the HsBracket extension constructor (XBracket !(XXBracket p)),
+when p = GhcTc, is used to hold the needed HsBracket GhcRn
+
+Note that a typed bracket is just fine: you'll see in tcTypedBracket that
+_tc_expr is just thrown away. It will comfortably come to rest inside a TExpBr
+(of type HsBracket GhcTc).
+-}
+
 type instance XExpBr      (GhcPass _) = NoExtField
 type instance XPatBr      (GhcPass _) = NoExtField
 type instance XDecBrL     (GhcPass _) = NoExtField
@@ -1783,14 +1803,17 @@ type instance XDecBrG     (GhcPass _) = NoExtField
 type instance XTypBr      (GhcPass _) = NoExtField
 type instance XVarBr      (GhcPass _) = NoExtField
 type instance XTExpBr     (GhcPass _) = NoExtField
-type instance XXBracket   (GhcPass _) = DataConCantHappen
+type instance XXBracket   GhcPs = DataConCantHappen
+type instance XXBracket   GhcRn = DataConCantHappen
+type instance XXBracket   GhcTc = HsBracket GhcRn   -- See Note [Type-checking untyped brackets]
 
 instance OutputableBndrId p
           => Outputable (HsBracket (GhcPass p)) where
   ppr = pprHsBracket
 
 
-pprHsBracket :: (OutputableBndrId p) => HsBracket (GhcPass p) -> SDoc
+pprHsBracket :: forall p. (OutputableBndrId p)
+             => HsBracket (GhcPass p) -> SDoc
 pprHsBracket (ExpBr _ e)   = thBrackets empty (ppr e)
 pprHsBracket (PatBr _ p)   = thBrackets (char 'p') (ppr p)
 pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)
@@ -1801,6 +1824,12 @@ pprHsBracket (VarBr _ True n)
 pprHsBracket (VarBr _ False n)
   = text "''" <> pprPrefixOcc (unLoc n)
 pprHsBracket (TExpBr _ e)  = thTyBrackets (ppr e)
+pprHsBracket (XBracket b)  = case ghcPass @p of
+#if __GLASGOW_HASKELL__ <= 900
+    GhcPs -> dataConCantHappen b
+    GhcRn -> dataConCantHappen b
+#endif
+    GhcTc -> pprHsBracket b
 
 thBrackets :: SDoc -> SDoc -> SDoc
 thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 3e47d88ade..1691db72a9 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -747,8 +747,9 @@ Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
 
 -- Template Haskell stuff
 
-dsExpr (HsBracket (HsBracketTc _ hs_wrapper ps) x) = dsBracket hs_wrapper x ps
-dsExpr (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)
+dsExpr (HsBracket (HsBracketTc _ hs_wrapper ps) (XBracket x)) = dsBracket hs_wrapper x ps -- See Note [Type-checking untyped brackets] in GHC.Hs.Expr
+dsExpr (HsBracket (HsBracketTc _ _ ps) _) = pprPanic "dsExpr:bracket" (ppr ps)
+dsExpr (HsSpliceE _ s)                    = pprPanic "dsExpr:splice" (ppr s)
 
 -- Arrow notation extension
 dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 674a3fc830..5acffaca7d 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -217,7 +217,7 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
                        rn_expr
                        (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)
                                                   (nlHsTyApp codeco [rep, expr_ty]))
-                                      (noLocA (HsBracket (HsBracketTc bracket_ty (Just wrapper) ps') brack))))
+                                      (noLocA (HsBracket (HsBracketTc bracket_ty (Just wrapper) ps') (XBracket brack)))))
                        meta_ty res_ty }
 tcTypedBracket _ other_brack _
   = pprPanic "tcTypedBracket" (ppr other_brack)
@@ -246,7 +246,7 @@ tcUntypedBracket rn_expr brack ps res_ty
        -- Unify the overall type of the bracket with the expected result
        -- type
        ; tcWrapResultO BracketOrigin rn_expr
-            (HsBracket (HsBracketTc expected_type brack_info ps') brack)
+            (HsBracket (HsBracketTc expected_type brack_info ps') (XBracket brack))
             expected_type res_ty
 
        }
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 12fdfffe48..dd3e8b4545 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -593,7 +593,7 @@ data HsExpr p
   --         'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnCloseQ'
 
   -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
-  | HsBracket  (XBracket p) (HsBracketBody p)
+  | HsBracket  (XBracket p) (HsBracket p)
 
   -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
   --         'GHC.Parser.Annotation.AnnClose'
@@ -636,9 +636,6 @@ data HsExpr p
 -- we paper it over with this new extension point.
 type family HsDoRn p
 
--- TODO: Temporary fix for HsBracket GhcTc body should be HsBracket GhcRn
-type family HsBracketBody p
-
 -- ---------------------------------------------------------------------
 
 data DotFieldOcc p
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 2c96ff49ea..ee8130df3a 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -1846,8 +1846,6 @@ instance ExactPrint (HsExpr GhcPs) where
   getAnnotationEntry (ExprWithTySig an _ _)       = fromAnn an
   getAnnotationEntry (ArithSeq an _ _)            = fromAnn an
   getAnnotationEntry (HsBracket an _)             = fromAnn an
-  getAnnotationEntry (HsRnBracketOut{})           = NoEntryVal
-  getAnnotationEntry (HsTcBracketOut{})           = NoEntryVal
   getAnnotationEntry (HsSpliceE an _)             = fromAnn an
   getAnnotationEntry (HsProc an _ _)              = fromAnn an
   getAnnotationEntry (HsStatic an _)              = fromAnn an