diff options
author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2020-02-17 19:46:13 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-02-20 21:22:11 -0500 |
commit | 466e1ad5d54cb2e8a3b6f16904b873cad882a736 (patch) | |
tree | 8a63ad350cb42a2aef09e4e0229eb01f82afda41 | |
parent | 8b76d4574d703ee66f346775d408220fdddb8155 (diff) | |
download | haskell-466e1ad5d54cb2e8a3b6f16904b873cad882a736.tar.gz |
Use TTG for HsSplicedT constructor
The constructor HsSplicedT occurs only in the GhcTc pass.
This enforces this fact statically via TTG.
-rw-r--r-- | compiler/GHC/Hs/Expr.hs | 17 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Iface/Ext/Ast.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/Rename/Splice.hs | 10 | ||||
-rw-r--r-- | compiler/typecheck/TcHsSyn.hs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcPatSyn.hs | 3 | ||||
-rw-r--r-- | compiler/typecheck/TcSplice.hs | 2 |
7 files changed, 26 insertions, 22 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 308b112886..9f97fc9ff7 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -2382,15 +2382,17 @@ data HsSplice id (XSpliced id) ThModFinalizers -- TH finalizers produced by the splice. (HsSplicedThing id) -- The result of splicing - | HsSplicedT - DelayedSplice | XSplice (XXSplice id) -- Note [Trees that Grow] extension point +newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data) + type instance XTypedSplice (GhcPass _) = NoExtField type instance XUntypedSplice (GhcPass _) = NoExtField type instance XQuasiQuote (GhcPass _) = NoExtField type instance XSpliced (GhcPass _) = NoExtField -type instance XXSplice (GhcPass _) = NoExtCon +type instance XXSplice GhcPs = NoExtCon +type instance XXSplice GhcRn = NoExtCon +type instance XXSplice GhcTc = HsSplicedT -- | A splice can appear with various decorations wrapped around it. This data -- type captures explicitly how it was originally written, for use in the pretty @@ -2552,7 +2554,7 @@ ppr_splice_decl :: (OutputableBndrId p) ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty ppr_splice_decl e = pprSplice e -pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc +pprSplice :: forall p. (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc pprSplice (HsTypedSplice _ DollarSplice n e) = ppr_splice (text "$$") n e empty pprSplice (HsTypedSplice _ BareSplice _ _ ) @@ -2563,8 +2565,11 @@ pprSplice (HsUntypedSplice _ BareSplice n e) = ppr_splice empty n e empty pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s pprSplice (HsSpliced _ _ thing) = ppr thing -pprSplice (HsSplicedT {}) = text "Unevaluated typed splice" -pprSplice (XSplice x) = ppr x +pprSplice (XSplice x) = case ghcPass @p of + GhcPs -> noExtCon x + GhcRn -> noExtCon x + GhcTc -> case x of + HsSplicedT _ -> text "Unevaluated typed splice" ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 970fc82463..07ab2959ba 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1389,7 +1389,6 @@ repSplice (HsTypedSplice _ _ n _) = rep_splice n repSplice (HsUntypedSplice _ _ n _) = rep_splice n repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) -repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e) repSplice (XSplice nec) = noExtCon nec rep_splice :: Name -> MetaM (Core a) diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 943b5a1562..690aa323c9 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -777,6 +777,7 @@ instance ( a ~ GhcPass p , ToHie (TScoped (ProtectedSig a)) , HasType (LPat a) , Data (HsSplice a) + , IsPass p ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where toHie (PS rsp scope pscope lpat@(L ospan opat)) = concatM $ getTypeNode lpat : case opat of @@ -1698,8 +1699,10 @@ instance ToHie (LBooleanFormula (Located Name)) where instance ToHie (Located HsIPName) where toHie (L span e) = makeNode e span -instance ( ToHie (LHsExpr a) +instance ( a ~ GhcPass p + , ToHie (LHsExpr a) , Data (HsSplice a) + , IsPass p ) => ToHie (Located (HsSplice a)) where toHie (L span sp) = concatM $ makeNode sp span : case sp of HsTypedSplice _ _ _ expr -> @@ -1713,9 +1716,11 @@ instance ( ToHie (LHsExpr a) ] HsSpliced _ _ _ -> [] - HsSplicedT _ -> - [] - XSplice _ -> [] + XSplice x -> case ghcPass @p of + GhcPs -> noExtCon x + GhcRn -> noExtCon x + GhcTc -> case x of + HsSplicedT _ -> [] instance ToHie (LRoleAnnotDecl GhcRn) where toHie (L span annot) = concatM $ makeNode annot span : case annot of diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 3f746ee39c..9a60a071c5 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -299,7 +299,8 @@ checkTopSpliceAllowed splice = do spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes) spliceExtension (HsTypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell) spliceExtension (HsUntypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell) - spliceExtension s = pprPanic "spliceExtension" (ppr s) + spliceExtension s@(HsSpliced {}) = pprPanic "spliceExtension" (ppr s) + spliceExtension (XSplice nec) = noExtCon nec ------------------ @@ -321,7 +322,6 @@ runRnSplice flavour run_meta ppr_res splice HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) - HsSplicedT {} -> pprPanic "runRnSplice" (ppr splice) XSplice nec -> noExtCon nec -- Typecheck the expression @@ -369,8 +369,6 @@ makePending _ splice@(HsTypedSplice {}) = pprPanic "makePending" (ppr splice) makePending _ splice@(HsSpliced {}) = pprPanic "makePending" (ppr splice) -makePending _ splice@(HsSplicedT {}) - = pprPanic "makePending" (ppr splice) makePending _ (XSplice nec) = noExtCon nec @@ -422,7 +420,6 @@ rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) , unitFV quoter') } rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) -rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice) rnSplice (XSplice nec) = noExtCon nec --------------------- @@ -734,8 +731,7 @@ spliceCtxt splice HsTypedSplice {} -> text "typed splice:" HsQuasiQuote {} -> text "quasi-quotation:" HsSpliced {} -> text "spliced expression:" - HsSplicedT {} -> text "spliced expression:" - XSplice {} -> text "spliced expression:" + XSplice nec -> noExtCon nec -- | The splice data to be logged data SpliceInfo diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index ea533d578e..cf69b279e2 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -795,7 +795,7 @@ zonkExpr env (HsTcBracketOut x wrap body bs) zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e return (PendingTcSplice n e') -zonkExpr env (HsSpliceE _ (HsSplicedT s)) = +zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) = runTopSplice s >>= zonkExpr env zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 129a0e5f10..d43461745b 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -980,7 +980,6 @@ tcPatToExpr name args pat = go pat go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) = go1 pat go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" - go1 (SplicePat _ (HsSplicedT{})) = panic "Invalid splice variety" -- The following patterns are not invertible. go1 p@(BangPat {}) = notInvertible p -- #14112 @@ -993,7 +992,7 @@ tcPatToExpr name args pat = go pat go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p - go1 p@(SplicePat _ (XSplice {})) = notInvertible p + go1 (SplicePat _ (XSplice nec)) = noExtCon nec notInvertible p = Left (not_invertible_msg p) diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index ed9895074b..390e088836 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -641,7 +641,7 @@ tcTopSplice expr res_ty ; lcl_env <- getLclEnv ; let delayed_splice = DelayedSplice lcl_env expr res_ty q_expr - ; return (HsSpliceE noExtField (HsSplicedT delayed_splice)) + ; return (HsSpliceE noExtField (XSplice (HsSplicedT delayed_splice))) } |