TTG: Refactor HsBracket

14 files changed, 74 insertions, 79 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 595adafdf9..881b005445 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -183,9 +183,37 @@ data HsWrap hs_syn = HsWrap HsWrapper      -- the wrapper
 
 deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)
 
-type instance HsBracketRn (GhcPass _) = GhcRn
-type instance PendingRnSplice' (GhcPass _) = PendingRnSplice
-type instance PendingTcSplice' (GhcPass _) = PendingTcSplice
+type instance HsDoRn (GhcPass _) = GhcRn
+
+-- ---------------------------------------------------------------------
+
+    -- See Note [Pending Splices]
+data HsBracketRn
+  = HsBracketRnTyped
+    (EpAnn [AddEpAnn])
+
+  | HsBracketRnUntyped
+    (EpAnn [AddEpAnn])
+    [PendingRnSplice]  -- Output of the renamer is the *original* renamed
+                       -- expression, plus
+                       -- _renamed_ splices to be type checked
+
+data HsBracketTc = HsBracketTc
+  Type
+  (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument
+                       -- to the quote.
+  [PendingTcSplice]    -- Output of the type checker is the *original*
+                       -- renamed expression, plus
+                       -- _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
 
 -- ---------------------------------------------------------------------
 
@@ -334,18 +362,6 @@ type instance XArithSeq      GhcPs = EpAnn [AddEpAnn]
 type instance XArithSeq      GhcRn = NoExtField
 type instance XArithSeq      GhcTc = PostTcExpr
 
-type instance XBracket       GhcPs = EpAnn [AddEpAnn]
-type instance XBracket       GhcRn = EpAnn [AddEpAnn]
-type instance XBracket       GhcTc = DataConCantHappen
-
-type instance XRnBracketOut  GhcPs = DataConCantHappen
-type instance XRnBracketOut  GhcRn = NoExtField
-type instance XRnBracketOut  GhcTc = DataConCantHappen
-
-type instance XTcBracketOut  GhcPs = DataConCantHappen
-type instance XTcBracketOut  GhcRn = DataConCantHappen
-type instance XTcBracketOut  GhcTc = Type -- Type of the TcBracketOut
-
 type instance XSpliceE       (GhcPass _) = EpAnnCO
 type instance XProc          (GhcPass _) = EpAnn [AddEpAnn]
 
@@ -641,11 +657,16 @@ ppr_expr (ExprWithTySig _ expr sig)
 ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
 
 ppr_expr (HsSpliceE _ s)         = pprSplice s
-ppr_expr (HsBracket _ b)         = pprHsBracket b
-ppr_expr (HsRnBracketOut _ e []) = ppr e
-ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps
-ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e
-ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)
+ppr_expr (HsBracket b e)
+  = case ghcPass @p of
+    GhcPs -> pprHsBracket e
+    GhcRn -> case b of
+      HsBracketRnTyped _ -> pprHsBracket e
+      HsBracketRnUntyped _ [] -> ppr e
+      HsBracketRnUntyped _ ps -> ppr e $$ text "pending(rn)" <+> ppr ps
+    GhcTc -> case b of
+      HsBracketTc _ty _wrap [] -> ppr e
+      HsBracketTc _ty _wrap ps -> ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)
 
 ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
   = hsep [text "proc", ppr pat, text "->", ppr cmd]
@@ -786,8 +807,6 @@ hsExprNeedsParens prec = go
     go (HsPragE{})                    = prec >= appPrec
     go (HsSpliceE{})                  = False
     go (HsBracket{})                  = False
-    go (HsRnBracketOut{})             = False
-    go (HsTcBracketOut{})             = False
     go (HsProc{})                     = prec > topPrec
     go (HsStatic{})                   = prec >= appPrec
     go (RecordCon{})                  = False
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index ff5131f6e0..f93df4ac67 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -388,6 +388,10 @@ deriving instance Data (HsBracket GhcPs)
 deriving instance Data (HsBracket GhcRn)
 deriving instance Data (HsBracket GhcTc)
 
+deriving instance Data HsBracketRn
+
+deriving instance Data HsBracketTc
+
 -- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p)
 deriving instance Data (ArithSeqInfo GhcPs)
 deriving instance Data (ArithSeqInfo GhcRn)
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index c985c9237c..a57cd80145 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -129,9 +129,7 @@ hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of
   Nothing -> asi_ty
   where
     asi_ty = arithSeqInfoType asi
-hsExprType (HsBracket v _) = dataConCantHappen v
-hsExprType (HsRnBracketOut v _ _) = dataConCantHappen v
-hsExprType (HsTcBracketOut ty _wrap _bracket _pending) = ty
+hsExprType (HsBracket (HsBracketTc ty _wrap _pending) _) = ty
 hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"
                                       (ppr e)
                                       -- Typed splices should have been eliminated during zonking, but we
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index e06f7b09f8..9fcfd9a81e 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -639,8 +639,6 @@ addTickHsExpr (ArithSeq ty wit arith_seq) =
 addTickHsExpr (HsPragE x p e) =
         liftM (HsPragE x p) (addTickLHsExpr e)
 addTickHsExpr e@(HsBracket     {})   = return e
-addTickHsExpr e@(HsTcBracketOut  {}) = return e
-addTickHsExpr e@(HsRnBracketOut  {}) = return e
 addTickHsExpr e@(HsSpliceE  {})      = return e
 addTickHsExpr e@(HsGetField {})      = return e
 addTickHsExpr e@(HsProjection {})    = return e
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index b510281dbd..3e47d88ade 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -747,8 +747,7 @@ Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
 
 -- Template Haskell stuff
 
-dsExpr (HsRnBracketOut x _ _)  = dataConCantHappen x
-dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps
+dsExpr (HsBracket (HsBracketTc _ hs_wrapper ps) x) = dsBracket hs_wrapper x ps
 dsExpr (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)
 
 -- Arrow notation extension
@@ -762,7 +761,6 @@ dsExpr (HsOverLabel x _) = dataConCantHappen x
 dsExpr (OpApp x _ _ _)   = dataConCantHappen x
 dsExpr (SectionL x _ _)  = dataConCantHappen x
 dsExpr (SectionR x _ _)  = dataConCantHappen x
-dsExpr (HsBracket x _)   = dataConCantHappen x
 
 ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
 ds_prag_expr (HsPragSCC _ _ cc) expr = do
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 215b8f4da8..6c8b113dec 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1637,8 +1637,6 @@ repE (XExpr (HsExpanded orig_expr ds_expr))
          else repE orig_expr }
 repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
 repE e@(HsBracket{}) = notHandled (ThExpressionForm e)
-repE e@(HsRnBracketOut{}) = notHandled (ThExpressionForm e)
-repE e@(HsTcBracketOut{}) = notHandled (ThExpressionForm e)
 repE e@(HsProc{}) = notHandled (ThExpressionForm e)
 
 {- Note [Quotation and rebindable syntax]
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index b6be92301f..3aba40407b 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1183,17 +1183,19 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
       HsStatic _ expr ->
         [ toHie expr
         ]
-      HsBracket _ b ->
-        [ toHie b
-        ]
-      HsRnBracketOut _ b p ->
-        [ toHie b
-        , toHie p
-        ]
-      HsTcBracketOut _ _wrap b p ->
-        [ toHie b
-        , toHie p
-        ]
+      HsBracket xbracket b -> case hiePass @p of
+        HieRn -> case xbracket of
+          HsBracketRnTyped _ ->
+            [ toHie b
+            ]
+          HsBracketRnUntyped _ p ->
+            [ toHie b
+            , toHie p
+            ]
+        HieTc | HsBracketTc _ _ p <- xbracket ->
+          [ toHie b
+          , toHie p
+          ]
       HsSpliceE _ x ->
         [ toHie $ L mspan x
         ]
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 54087c5b4e..aae22dfd93 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -107,7 +107,7 @@ rnBracket e br_body
                         ; (body', fvs_e) <-
                           setStage (Brack cur_stage RnPendingTyped) $
                                    rn_bracket cur_stage br_body
-                        ; return (HsBracket noAnn body', fvs_e) }
+                        ; return (HsBracket (HsBracketRnTyped noAnn) body', fvs_e) }
 
             False -> do { traceRn "Renaming untyped TH bracket" empty
                         ; ps_var <- newMutVar []
@@ -117,7 +117,7 @@ rnBracket e br_body
                           setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
                                    rn_bracket cur_stage br_body
                         ; pendings <- readMutVar ps_var
-                        ; return (HsRnBracketOut noExtField body' pendings, fvs_e) }
+                        ; return (HsBracket (HsBracketRnUntyped noAnn pendings) body', fvs_e) }
        }
 
 rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 3043bed44c..6dadf6286c 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -861,8 +861,9 @@ tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
   = do addModFinalizersWithLclEnv mod_finalizers
        tcExpr expr res_ty
 tcExpr (HsSpliceE _ splice)          res_ty = tcSpliceExpr splice res_ty
-tcExpr e@(HsBracket _ brack)         res_ty = tcTypedBracket e brack res_ty
-tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty
+tcExpr e@(HsBracket brack body)           res_ty = case brack of
+  HsBracketRnTyped _     -> tcTypedBracket e body res_ty
+  HsBracketRnUntyped _ ps -> tcUntypedBracket e body ps res_ty
 
 {-
 ************************************************************************
@@ -875,7 +876,6 @@ tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty
 tcExpr (HsOverLabel {})    ty = pprPanic "tcExpr:HsOverLabel"  (ppr ty)
 tcExpr (SectionL {})       ty = pprPanic "tcExpr:SectionL"    (ppr ty)
 tcExpr (SectionR {})       ty = pprPanic "tcExpr:SectionR"    (ppr ty)
-tcExpr (HsTcBracketOut x _ _ _) _ = dataConCantHappen x
 
 
 {-
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 2be524e1fc..674a3fc830 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 (HsTcBracketOut bracket_ty (Just wrapper) brack ps'))))
+                                      (noLocA (HsBracket (HsBracketTc bracket_ty (Just wrapper) ps') 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
-            (HsTcBracketOut expected_type brack_info brack ps')
+            (HsBracket (HsBracketTc expected_type brack_info ps') brack)
             expected_type res_ty
 
        }
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index ebbf802026..b8ec635bd4 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -706,8 +706,6 @@ exprCtOrigin (ExprWithTySig {})  = ExprSigOrigin
 exprCtOrigin (ArithSeq {})       = Shouldn'tHappenOrigin "arithmetic sequence"
 exprCtOrigin (HsPragE _ _ e)     = lexprCtOrigin e
 exprCtOrigin (HsBracket {})      = Shouldn'tHappenOrigin "TH bracket"
-exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut"
-exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"
 exprCtOrigin (HsSpliceE {})      = Shouldn'tHappenOrigin "TH splice"
 exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc"
 exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression"
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 197a8d8104..0628ab428c 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -778,13 +778,11 @@ zonkExpr env (HsAppType ty e t)
        return (HsAppType new_ty new_e t)
        -- NB: the type is an HsType; can't zonk that!
 
-zonkExpr _ (HsRnBracketOut x _ _) = dataConCantHappen x
-
-zonkExpr env (HsTcBracketOut ty wrap body bs)
+zonkExpr env (HsBracket (HsBracketTc ty wrap bs) body)
   = do wrap' <- traverse zonkQuoteWrap wrap
        bs' <- mapM (zonk_b env) bs
        new_ty <- zonkTcTypeToTypeX env ty
-       return (HsTcBracketOut new_ty wrap' body bs')
+       return (HsBracket (HsBracketTc new_ty wrap' bs') body)
   where
     zonkQuoteWrap (QuoteWrapper ev ty) = do
         let ev' = zonkIdOcc env ev
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 92cf9d5f20..12fdfffe48 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -33,7 +33,6 @@ import Language.Haskell.Syntax.Type
 import Language.Haskell.Syntax.Binds
 
 -- others:
-import GHC.Tc.Types.Evidence
 import GHC.Core.DataCon (FieldLabelString)
 import GHC.Types.Name
 import GHC.Types.Basic
@@ -594,23 +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) (HsBracket p)
-
-    -- See Note [Pending Splices]
-  | HsRnBracketOut
-      (XRnBracketOut p)
-      (HsBracket (HsBracketRn p)) -- Output of the renamer is the *original* renamed
-                                  -- expression, plus
-      [PendingRnSplice' p] -- _renamed_ splices to be type checked
-
-  | HsTcBracketOut
-      (XTcBracketOut p)
-      (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument
-                           -- to the quote.
-      (HsBracket (HsBracketRn p)) -- Output of the type checker is the *original*
-                                 -- renamed expression, plus
-      [PendingTcSplice' p] -- _typechecked_ splices to be
-                           -- pasted back in by the desugarer
+  | HsBracket  (XBracket p) (HsBracketBody p)
 
   -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',
   --         'GHC.Parser.Annotation.AnnClose'
@@ -651,9 +634,10 @@ data HsExpr p
 
 -- | The AST used to hard-refer to GhcPass, which was a layer violation. For now,
 -- we paper it over with this new extension point.
-type family HsBracketRn p
-type family PendingRnSplice' p
-type family PendingTcSplice' p
+type family HsDoRn p
+
+-- TODO: Temporary fix for HsBracket GhcTc body should be HsBracket GhcRn
+type family HsBracketBody p
 
 -- ---------------------------------------------------------------------
 
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 862c212c90..93c66fce35 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -430,8 +430,6 @@ type family XProjection     x
 type family XExprWithTySig  x
 type family XArithSeq       x
 type family XBracket        x
-type family XRnBracketOut   x
-type family XTcBracketOut   x
 type family XSpliceE        x
 type family XProc           x
 type family XStatic         x