From 19163397000ae3ce9886a75bef900d35774d864e Mon Sep 17 00:00:00 2001 From: romes Date: Wed, 9 Mar 2022 01:33:29 +0000 Subject: 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 --- compiler/GHC/Hs/Expr.hs | 53 ++++++++++++++++++++++++-------- compiler/GHC/HsToCore/Expr.hs | 5 +-- compiler/GHC/Tc/Gen/Splice.hs | 4 +-- compiler/Language/Haskell/Syntax/Expr.hs | 5 +-- utils/check-exact/ExactPrint.hs | 2 -- 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 -- cgit v1.2.1