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
(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)) <>
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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)))
}
......
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