HsUntypedBracket TC through XExprwip/shrink-ast-deps-xexpr

8 files changed, 42 insertions, 38 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 60ea73ca6d..bef21bd755 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -248,16 +248,16 @@ data HsBracketTc thing = HsBracketTc
                        -- _typechecked_ splices to be
                        -- pasted back in by the desugarer
 
-type instance XTypedBracket GhcPs = EpAnn [AddEpAnn]
-type instance XTypedBracket GhcRn = EpAnn [AddEpAnn]
-type instance XTypedBracket GhcTc = HsBracketTc (LHsExpr GhcRn) -- See Note [The life cycle of a TH quotation]
+type instance XTypedBracket GhcPs   = EpAnn [AddEpAnn]
+type instance XTypedBracket GhcRn   = EpAnn [AddEpAnn]
+type instance XTypedBracket GhcTc   = HsBracketTc (LHsExpr GhcRn)  -- See Note [The life cycle of a TH quotation]
 type instance XUntypedBracket GhcPs = EpAnn [AddEpAnn]
 type instance XUntypedBracket GhcRn = (EpAnn [AddEpAnn], [PendingRnSplice])
                        -- See Note [Pending Splices]
                        -- Output of the renamer is the *original* renamed
                        -- expression, plus
                        -- _renamed_ splices to be type checked
-type instance XUntypedBracket GhcTc = HsBracketTc (HsQuote GhcRn) -- See Note [The life cycle of a TH quotation]
+type instance XUntypedBracket GhcTc = DataConCantHappen -- See Note [The life cycle of a TH quotation]
 
 -- ---------------------------------------------------------------------
 
@@ -507,6 +507,9 @@ data XXExprGhcTc
      Int                                -- module-local tick number for False
      (LHsExpr GhcTc)                    -- sub-expression
 
+  ---------------------------------------
+  -- Haskell untyped brackets during typechecking
+  | HsUntypedBracketTc (HsBracketTc (HsQuote GhcRn)) -- See Note [The life cycle of a TH quotation]
 
 {- *********************************************************************
 *                                                                      *
@@ -716,9 +719,7 @@ ppr_expr (HsUntypedBracket b e)
     GhcRn -> case b of
       (_, []) -> ppr e
       (_, ps) -> ppr e $$ text "pending(rn)" <+> ppr ps
-    GhcTc -> case b of
-      HsBracketTc rne  _ty _wrap [] -> ppr rne
-      HsBracketTc rne  _ty _wrap ps -> ppr rne $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)
+    GhcTc -> dataConCantHappen b
 
 ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
   = hsep [text "proc", ppr pat, text "->", ppr cmd]
@@ -759,6 +760,10 @@ instance Outputable XXExprGhcTc where
             text ">(",
             ppr exp, text ")"]
 
+  ppr (HsUntypedBracketTc b) = case b of
+    HsBracketTc rne  _ty _wrap [] -> ppr rne
+    HsBracketTc rne  _ty _wrap ps -> ppr rne $$ text "pending(tc)" <+> ppr ps
+
 ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
 ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)
 ppr_infix_expr (HsRecSel _ f)       = Just (pprInfixOcc f)
@@ -780,6 +785,7 @@ ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a
 ppr_infix_expr_tc (ConLikeTc {})                   = Nothing
 ppr_infix_expr_tc (HsTick {})                      = Nothing
 ppr_infix_expr_tc (HsBinTick {})                   = Nothing
+ppr_infix_expr_tc (HsUntypedBracketTc {})          = Nothing
 
 ppr_apps :: (OutputableBndrId p)
          => HsExpr (GhcPass p)
@@ -879,6 +885,7 @@ hsExprNeedsParens prec = go
     go_x_tc (ConLikeTc {})                   = False
     go_x_tc (HsTick _ (L _ e))               = hsExprNeedsParens prec e
     go_x_tc (HsBinTick _ _ (L _ e))          = hsExprNeedsParens prec e
+    go_x_tc (HsUntypedBracketTc {})          = False
 
     go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool
     go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a
@@ -921,6 +928,7 @@ isAtomicHsExpr (XExpr x)
     go_x_tc (ConLikeTc {})                   = True
     go_x_tc (HsTick {}) = False
     go_x_tc (HsBinTick {}) = False
+    go_x_tc (HsUntypedBracketTc {}) = False
 
     go_x_rn (HsExpanded a _) = isAtomicHsExpr a
 
@@ -1837,7 +1845,6 @@ type instance XDecBrL GhcPs       = NoExtField
 type instance XDecBrG GhcPs       = NoExtField
 type instance XTypBr  GhcPs       = NoExtField
 type instance XVarBr  GhcPs       = NoExtField
-type instance XXQuote GhcPs       = DataConCantHappen
 
 type instance XExpBr  GhcRn       = NoExtField
 type instance XPatBr  GhcRn       = NoExtField
@@ -1845,7 +1852,6 @@ type instance XDecBrL GhcRn       = NoExtField
 type instance XDecBrG GhcRn       = NoExtField
 type instance XTypBr  GhcRn       = NoExtField
 type instance XVarBr  GhcRn       = NoExtField
-type instance XXQuote GhcRn       = DataConCantHappen
 
 -- See Note [Constructing HsQuote GhcTc]
 type instance XExpBr  GhcTc       = DataConCantHappen
@@ -1854,7 +1860,7 @@ type instance XDecBrL GhcTc       = DataConCantHappen
 type instance XDecBrG GhcTc       = DataConCantHappen
 type instance XTypBr  GhcTc       = DataConCantHappen
 type instance XVarBr  GhcTc       = DataConCantHappen
-type instance XXQuote GhcTc       = ()
+type instance XXQuote (GhcPass _) = DataConCantHappen
 
 instance OutputableBndrId p
           => Outputable (HsQuote (GhcPass p)) where
@@ -1871,12 +1877,6 @@ instance OutputableBndrId p
         = char '\'' <> pprPrefixOcc (unLoc n)
       pprHsQuote (VarBr _ False n)
         = text "''" <> pprPrefixOcc (unLoc n)
-      pprHsQuote (XQuote b)  = case ghcPass @p of
-#if __GLASGOW_HASKELL__ <= 900
-          GhcPs -> dataConCantHappen b
-          GhcRn -> dataConCantHappen b
-#endif
-          GhcTc -> ppr () -- romes TODO: so what do we do when we want to pretty print an HsQuote GhcTc? probably some pprPanic right? that's unfortunate...
 
 thBrackets :: SDoc -> SDoc -> SDoc
 thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index fef85d1c60..afdb00fe94 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -386,7 +386,7 @@ deriving instance Data (HsSplicedThing GhcTc)
 -- deriving instance (DataIdLR p p) => Data (HsQuote p)
 deriving instance Data (HsQuote GhcPs)
 deriving instance Data (HsQuote GhcRn)
-deriving instance Data (HsQuote GhcTc)
+deriving instance Data (HsQuote GhcTc) -- romes TODO: See, this is unfortunate, when XUntypedBracket Tc == DataConCantHappen there's no way to have HsQuote
 
 deriving instance Data thing => Data (HsBracketTc thing)
 
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 4952256baf..f126285ed3 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -130,7 +130,7 @@ hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of
   where
     asi_ty = arithSeqInfoType asi
 hsExprType (HsTypedBracket   (HsBracketTc _ ty _wrap _pending) _) = ty
-hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty
+hsExprType e@(HsUntypedBracket _ _) = pprPanic "hsExprType: Unexpected HsUntypedBracket" (ppr e)
 hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"
                                       (ppr e)
                                       -- Typed splices should have been eliminated during zonking, but we
@@ -144,6 +144,7 @@ hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e
 hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
 hsExprType (XExpr (HsTick _ e)) = lhsExprType e
 hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
+hsExprType (XExpr (HsUntypedBracketTc (HsBracketTc _ ty _ _))) = ty
 
 arithSeqInfoType :: ArithSeqInfo GhcTc -> Type
 arithSeqInfoType asi = mkListTy $ case asi of
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index e1e8489fe1..e473271cc2 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -664,6 +664,7 @@ addTickHsExpr (XExpr (HsTick t e)) =
         liftM (XExpr . HsTick t) (addTickLHsExprNever e)
 addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =
         liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)
+addTickHsExpr e@(XExpr (HsUntypedBracketTc _)) = return e
 
 addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
 addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 1d471d6321..f0cb0a0697 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -285,6 +285,7 @@ dsExpr e@(XExpr ext_expr_tc)
         do { assert (exprType e2 `eqType` boolTy)
             mkBinaryTickBox ixT ixF e2
           }
+      HsUntypedBracketTc (HsBracketTc x _ hs_wrapper ps) -> dsUntypedBracket hs_wrapper x ps
 
 dsExpr (NegApp _ (L loc
                     (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
@@ -749,7 +750,7 @@ Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
 -- See Note [The life cycle of a TH quotation]
 
 dsExpr (HsTypedBracket (HsBracketTc x _ hs_wrapper ps) _) = dsTypedBracket hs_wrapper x ps
-dsExpr (HsUntypedBracket (HsBracketTc x _ hs_wrapper ps) _) = dsUntypedBracket hs_wrapper x ps
+dsExpr (HsUntypedBracket _ _) = pprPanic "dsExpr:untypedBracket" undefined
 dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
 
 -- Arrow notation extension
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 9ce99f3fdb..693226e755 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1196,10 +1196,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
             [ toHie b
             , toHie p
             ]
-        HieTc | HsBracketTc _ _ _ p <- xbracket ->
-          [ toHie b
-          , toHie p
-          ]
+        HieTc -> []
       HsSpliceE _ x ->
         [ toHie $ L mspan x
         ]
@@ -1221,6 +1218,9 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
              HsBinTick _ _ expr
                -> [ toHie expr
                   ]
+             HsUntypedBracketTc (HsBracketTc _ _ _ p)
+               -> [ toHie p
+                  ]
         | otherwise -> []
 
 -- NOTE: no longer have the location
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 5474f42d6c..9c28818db5 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -249,7 +249,7 @@ tcUntypedBracket rn_expr brack ps res_ty
        -- Unify the overall type of the bracket with the expected result
        -- type
        ; tcWrapResultO BracketOrigin rn_expr
-            (HsUntypedBracket (HsBracketTc brack expected_type brack_info ps') (XQuote ()))
+            (XExpr (HsUntypedBracketTc (HsBracketTc brack expected_type brack_info ps')))
             expected_type res_ty
 
        }
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 45e6ec9a02..84113a15a0 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -793,20 +793,6 @@ zonkExpr env (HsTypedBracket (HsBracketTc hsb_thing ty wrap bs) body)
     zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
                                            return (PendingTcSplice n e')
 
-zonkExpr env (HsUntypedBracket (HsBracketTc hsb_thing ty wrap bs) body)
-  = do wrap' <- traverse zonkQuoteWrap wrap
-       bs' <- mapM (zonk_b env) bs
-       new_ty <- zonkTcTypeToTypeX env ty
-       return (HsUntypedBracket (HsBracketTc hsb_thing new_ty wrap' bs') body)
-  where
-    zonkQuoteWrap (QuoteWrapper ev ty) = do
-        let ev' = zonkIdOcc env ev
-        ty' <- zonkTcTypeToTypeX env ty
-        return (QuoteWrapper ev' ty')
-
-    zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
-                                           return (PendingTcSplice n e')
-
 zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =
   runTopSplice s >>= zonkExpr env
 
@@ -950,6 +936,21 @@ zonkExpr env (XExpr (ConLikeTc con tvs tys))
     -- The tvs come straight from the data-con, and so are strictly redundant
     -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head
 
+zonkExpr env (XExpr (HsUntypedBracketTc (HsBracketTc hsb_thing ty wrap bs)))
+  = do wrap' <- traverse zonkQuoteWrap wrap
+       bs' <- mapM (zonk_b env) bs
+       new_ty <- zonkTcTypeToTypeX env ty
+       return (XExpr $ HsUntypedBracketTc (HsBracketTc hsb_thing new_ty wrap' bs'))
+  where
+    zonkQuoteWrap (QuoteWrapper ev ty) = do
+        let ev' = zonkIdOcc env ev
+        ty' <- zonkTcTypeToTypeX env ty
+        return (QuoteWrapper ev' ty')
+
+    zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
+                                           return (PendingTcSplice n e')
+
+
 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
 
 -------------------------------------------------------------------------