Use TTG for HsSplicedT constructor

The constructor HsSplicedT occurs only in the GhcTc pass.
This enforces this fact statically via TTG.

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)))
 
        }