Commit 466e1ad5 authored by Krzysztof Gogolewski's avatar Krzysztof Gogolewski Committed by Marge Bot

Use TTG for HsSplicedT constructor

The constructor HsSplicedT occurs only in the GhcTc pass.
This enforces this fact statically via TTG.
parent 8b76d457
...@@ -2382,15 +2382,17 @@ data HsSplice id ...@@ -2382,15 +2382,17 @@ data HsSplice id
(XSpliced id) (XSpliced id)
ThModFinalizers -- TH finalizers produced by the splice. ThModFinalizers -- TH finalizers produced by the splice.
(HsSplicedThing id) -- The result of splicing (HsSplicedThing id) -- The result of splicing
| HsSplicedT
DelayedSplice
| XSplice (XXSplice id) -- Note [Trees that Grow] extension point | XSplice (XXSplice id) -- Note [Trees that Grow] extension point
newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data)
type instance XTypedSplice (GhcPass _) = NoExtField type instance XTypedSplice (GhcPass _) = NoExtField
type instance XUntypedSplice (GhcPass _) = NoExtField type instance XUntypedSplice (GhcPass _) = NoExtField
type instance XQuasiQuote (GhcPass _) = NoExtField type instance XQuasiQuote (GhcPass _) = NoExtField
type instance XSpliced (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 -- | 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 -- type captures explicitly how it was originally written, for use in the pretty
...@@ -2552,7 +2554,7 @@ ppr_splice_decl :: (OutputableBndrId p) ...@@ -2552,7 +2554,7 @@ ppr_splice_decl :: (OutputableBndrId p)
ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty
ppr_splice_decl e = pprSplice e 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) pprSplice (HsTypedSplice _ DollarSplice n e)
= ppr_splice (text "$$") n e empty = ppr_splice (text "$$") n e empty
pprSplice (HsTypedSplice _ BareSplice _ _ ) pprSplice (HsTypedSplice _ BareSplice _ _ )
...@@ -2563,8 +2565,11 @@ pprSplice (HsUntypedSplice _ BareSplice n e) ...@@ -2563,8 +2565,11 @@ pprSplice (HsUntypedSplice _ BareSplice n e)
= ppr_splice empty n e empty = ppr_splice empty n e empty
pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s
pprSplice (HsSpliced _ _ thing) = ppr thing pprSplice (HsSpliced _ _ thing) = ppr thing
pprSplice (HsSplicedT {}) = text "Unevaluated typed splice" pprSplice (XSplice x) = case ghcPass @p of
pprSplice (XSplice x) = ppr x 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 :: OutputableBndr p => p -> p -> FastString -> SDoc
ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>
......
...@@ -1389,7 +1389,6 @@ repSplice (HsTypedSplice _ _ n _) = rep_splice n ...@@ -1389,7 +1389,6 @@ repSplice (HsTypedSplice _ _ n _) = rep_splice n
repSplice (HsUntypedSplice _ _ n _) = rep_splice n repSplice (HsUntypedSplice _ _ n _) = rep_splice n
repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n
repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e)
repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e)
repSplice (XSplice nec) = noExtCon nec repSplice (XSplice nec) = noExtCon nec
rep_splice :: Name -> MetaM (Core a) rep_splice :: Name -> MetaM (Core a)
......
...@@ -777,6 +777,7 @@ instance ( a ~ GhcPass p ...@@ -777,6 +777,7 @@ instance ( a ~ GhcPass p
, ToHie (TScoped (ProtectedSig a)) , ToHie (TScoped (ProtectedSig a))
, HasType (LPat a) , HasType (LPat a)
, Data (HsSplice a) , Data (HsSplice a)
, IsPass p
) => ToHie (PScoped (Located (Pat (GhcPass p)))) where ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where
toHie (PS rsp scope pscope lpat@(L ospan opat)) = toHie (PS rsp scope pscope lpat@(L ospan opat)) =
concatM $ getTypeNode lpat : case opat of concatM $ getTypeNode lpat : case opat of
...@@ -1698,8 +1699,10 @@ instance ToHie (LBooleanFormula (Located Name)) where ...@@ -1698,8 +1699,10 @@ instance ToHie (LBooleanFormula (Located Name)) where
instance ToHie (Located HsIPName) where instance ToHie (Located HsIPName) where
toHie (L span e) = makeNode e span toHie (L span e) = makeNode e span
instance ( ToHie (LHsExpr a) instance ( a ~ GhcPass p
, ToHie (LHsExpr a)
, Data (HsSplice a) , Data (HsSplice a)
, IsPass p
) => ToHie (Located (HsSplice a)) where ) => ToHie (Located (HsSplice a)) where
toHie (L span sp) = concatM $ makeNode sp span : case sp of toHie (L span sp) = concatM $ makeNode sp span : case sp of
HsTypedSplice _ _ _ expr -> HsTypedSplice _ _ _ expr ->
...@@ -1713,9 +1716,11 @@ instance ( ToHie (LHsExpr a) ...@@ -1713,9 +1716,11 @@ instance ( ToHie (LHsExpr a)
] ]
HsSpliced _ _ _ -> HsSpliced _ _ _ ->
[] []
HsSplicedT _ -> XSplice x -> case ghcPass @p of
[] GhcPs -> noExtCon x
XSplice _ -> [] GhcRn -> noExtCon x
GhcTc -> case x of
HsSplicedT _ -> []
instance ToHie (LRoleAnnotDecl GhcRn) where instance ToHie (LRoleAnnotDecl GhcRn) where
toHie (L span annot) = concatM $ makeNode annot span : case annot of toHie (L span annot) = concatM $ makeNode annot span : case annot of
......
...@@ -299,7 +299,8 @@ checkTopSpliceAllowed splice = do ...@@ -299,7 +299,8 @@ checkTopSpliceAllowed splice = do
spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes) spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes)
spliceExtension (HsTypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell) spliceExtension (HsTypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell)
spliceExtension (HsUntypedSplice {}) = ("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 ...@@ -321,7 +322,6 @@ runRnSplice flavour run_meta ppr_res splice
HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str
HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice)
HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) HsSpliced {} -> pprPanic "runRnSplice" (ppr splice)
HsSplicedT {} -> pprPanic "runRnSplice" (ppr splice)
XSplice nec -> noExtCon nec XSplice nec -> noExtCon nec
-- Typecheck the expression -- Typecheck the expression
...@@ -369,8 +369,6 @@ makePending _ splice@(HsTypedSplice {}) ...@@ -369,8 +369,6 @@ makePending _ splice@(HsTypedSplice {})
= pprPanic "makePending" (ppr splice) = pprPanic "makePending" (ppr splice)
makePending _ splice@(HsSpliced {}) makePending _ splice@(HsSpliced {})
= pprPanic "makePending" (ppr splice) = pprPanic "makePending" (ppr splice)
makePending _ splice@(HsSplicedT {})
= pprPanic "makePending" (ppr splice)
makePending _ (XSplice nec) makePending _ (XSplice nec)
= noExtCon nec = noExtCon nec
...@@ -422,7 +420,6 @@ rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) ...@@ -422,7 +420,6 @@ rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)
, unitFV quoter') } , unitFV quoter') }
rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)
rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice)
rnSplice (XSplice nec) = noExtCon nec rnSplice (XSplice nec) = noExtCon nec
--------------------- ---------------------
...@@ -734,8 +731,7 @@ spliceCtxt splice ...@@ -734,8 +731,7 @@ spliceCtxt splice
HsTypedSplice {} -> text "typed splice:" HsTypedSplice {} -> text "typed splice:"
HsQuasiQuote {} -> text "quasi-quotation:" HsQuasiQuote {} -> text "quasi-quotation:"
HsSpliced {} -> text "spliced expression:" HsSpliced {} -> text "spliced expression:"
HsSplicedT {} -> text "spliced expression:" XSplice nec -> noExtCon nec
XSplice {} -> text "spliced expression:"
-- | The splice data to be logged -- | The splice data to be logged
data SpliceInfo data SpliceInfo
......
...@@ -795,7 +795,7 @@ zonkExpr env (HsTcBracketOut x wrap body bs) ...@@ -795,7 +795,7 @@ zonkExpr env (HsTcBracketOut x wrap body bs)
zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
return (PendingTcSplice n e') return (PendingTcSplice n e')
zonkExpr env (HsSpliceE _ (HsSplicedT s)) = zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =
runTopSplice s >>= zonkExpr env runTopSplice s >>= zonkExpr env
zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
......
...@@ -980,7 +980,6 @@ tcPatToExpr name args pat = go pat ...@@ -980,7 +980,6 @@ tcPatToExpr name args pat = go pat
go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go1 pat = go1 pat
go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
go1 (SplicePat _ (HsSplicedT{})) = panic "Invalid splice variety"
-- The following patterns are not invertible. -- The following patterns are not invertible.
go1 p@(BangPat {}) = notInvertible p -- #14112 go1 p@(BangPat {}) = notInvertible p -- #14112
...@@ -993,7 +992,7 @@ tcPatToExpr name args pat = go pat ...@@ -993,7 +992,7 @@ tcPatToExpr name args pat = go pat
go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p
go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
go1 p@(SplicePat _ (HsQuasiQuote {})) = 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) notInvertible p = Left (not_invertible_msg p)
......
...@@ -641,7 +641,7 @@ tcTopSplice expr res_ty ...@@ -641,7 +641,7 @@ tcTopSplice expr res_ty
; lcl_env <- getLclEnv ; lcl_env <- getLclEnv
; let delayed_splice ; let delayed_splice
= DelayedSplice lcl_env expr res_ty q_expr = DelayedSplice lcl_env expr res_ty q_expr
; return (HsSpliceE noExtField (HsSplicedT delayed_splice)) ; return (HsSpliceE noExtField (XSplice (HsSplicedT delayed_splice)))
} }
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment