summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2020-03-27 17:22:28 -0400
committerRyan Scott <ryan.gl.scott@gmail.com>2020-04-07 19:43:20 -0400
commit04b6cf947ea065a210a216cc91f918cc1660d430 (patch)
tree60d3192ca3997385988bab216707193cb4c3c2da /compiler/GHC/Tc
parent255418da5d264fb2758bc70925adb2094f34adc3 (diff)
downloadhaskell-04b6cf947ea065a210a216cc91f918cc1660d430.tar.gz
Make NoExtCon fields strictwip/strict-NoExtCon
This changes every unused TTG extension constructor to be strict in its field so that the pattern-match coverage checker is smart enough any such constructors are unreachable in pattern matches. This lets us remove nearly every use of `noExtCon` in the GHC API. The only ones we cannot remove are ones underneath uses of `ghcPass`, but that is only because GHC 8.8's and 8.10's coverage checkers weren't smart enough to perform this kind of reasoning. GHC HEAD's coverage checker, on the other hand, _is_ smart enough, so we guard these uses of `noExtCon` with CPP for now. Bumps the `haddock` submodule. Fixes #17992.
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Deriv.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Annotation.hs1
-rw-r--r--compiler/GHC/Tc/Gen/Arrow.hs5
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Default.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs8
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs22
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs10
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Rule.hs3
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs1
-rw-r--r--compiler/GHC/Tc/Module.hs3
-rw-r--r--compiler/GHC/Tc/TyCl.hs33
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs6
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs7
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs4
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs7
-rw-r--r--compiler/GHC/Tc/Utils/Instantiate.hs1
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs38
20 files changed, 10 insertions, 159 deletions
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index 9831c841e4..5630bde863 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -689,7 +689,6 @@ deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
else Just <$> mkEqnHelp (fmap unLoc overlap_mode)
tvs' cls inst_tys'
deriv_ctxt' mb_deriv_strat' }
-deriveStandalone (L _ (XDerivDecl nec)) = noExtCon nec
-- Typecheck the type in a standalone deriving declaration.
--
@@ -734,11 +733,6 @@ tcStandaloneDerivInstType ctxt
let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
pure (tvs, SupplyContext theta, cls, inst_tys)
-tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs nec))
- = noExtCon nec
-tcStandaloneDerivInstType _ (XHsWildCardBndrs nec)
- = noExtCon nec
-
warnUselessTypeable :: TcM ()
warnUselessTypeable
= do { warn <- woptM Opt_WarnDerivingTypeable
diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs
index 00c52ea247..ef7168076f 100644
--- a/compiler/GHC/Tc/Gen/Annotation.hs
+++ b/compiler/GHC/Tc/Gen/Annotation.hs
@@ -58,7 +58,6 @@ tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do
where
safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."
, text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]
-tcAnnotation (L _ (XAnnDecl nec)) = noExtCon nec
annProvenanceToTarget :: Module -> AnnProvenance Name
-> AnnTarget Name
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index 435bf4d89c..9a30f56365 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -128,7 +128,6 @@ tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)
do { cmd' <- tcCmd env cmd cmd_ty
; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }
-tcCmdTop _ (L _ (XCmdTop nec)) _ = noExtCon nec
----------------------------------------
tcCmd :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)
@@ -273,14 +272,12 @@ tc_cmd env
= do { (binds', grhss') <- tcLocalBinds binds $
mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss
; return (GRHSs x grhss' (L l binds')) }
- tc_grhss (XGRHSs nec) _ _ = noExtCon nec
tc_grhs stk_ty res_ty (GRHS x guards body)
= do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
\ res_ty -> tcCmd env body
(stk_ty, checkingExpType "tc_grhs" res_ty)
; return (GRHS x guards' rhs') }
- tc_grhs _ _ (XGRHS nec) = noExtCon nec
-------------------------------------------
-- Do notation
@@ -325,8 +322,6 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)
; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }
-tc_cmd _ (XCmd nec) _ = noExtCon nec
-
-----------------------------------------------------------------
-- Base case for illegal commands
-- This is where expressions that aren't commands get rejected
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 6750a77500..8977ff3cd4 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -358,16 +358,12 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
; let d = toDict ipClass p ty `fmap` expr'
; return (ip_id, (IPBind noExtField (Right ip_id) d)) }
tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"
- tc_ip_bind _ (XIPBind nec) = noExtCon nec
-- Coerces a `t` into a dictionary for `IP "x" t`.
-- co : t -> IP "x" t
toDict ipClass x ty = mkHsWrap $ mkWpCastR $
wrapIP $ mkClassPred ipClass [x,ty]
-tcLocalBinds (HsIPBinds _ (XHsIPBinds nec)) _ = noExtCon nec
-tcLocalBinds (XHsLocalBindsLR nec) _ = noExtCon nec
-
{- Note [Implicit parameter untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We add the type variables in the types of the implicit parameters
diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs
index ab3ef76fca..29fb7ee7e0 100644
--- a/compiler/GHC/Tc/Gen/Default.hs
+++ b/compiler/GHC/Tc/Gen/Default.hs
@@ -66,7 +66,6 @@ tcDefaults [L locn (DefaultDecl _ mono_tys)]
tcDefaults decls@(L locn (DefaultDecl _ _) : _)
= setSrcSpan locn $
failWithTc (dupDefaultDeclErr decls)
-tcDefaults (L _ (XDefaultDecl nec):_) = noExtCon nec
tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
@@ -98,10 +97,9 @@ dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)
= hang (text "Multiple default declarations")
2 (vcat (map pp dup_things))
where
+ pp :: Located (DefaultDecl GhcRn) -> SDoc
pp (L locn (DefaultDecl _ _))
= text "here was another default declaration" <+> ppr locn
- pp (L _ (XDefaultDecl nec)) = noExtCon nec
-dupDefaultDeclErr (L _ (XDefaultDecl nec) : _) = noExtCon nec
dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
badDefaultTy :: Type -> [Class] -> SDoc
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 55f2a105c6..3468a015e5 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -203,7 +203,6 @@ tcExpr (HsPragE x prag expr) res_ty
tc_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann
tc_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl
tc_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo
- tc_prag (XHsPragE x) = noExtCon x
tcExpr (HsOverLit x lit) res_ty
= do { lit' <- newOverloadedLit lit res_ty
@@ -1406,7 +1405,6 @@ tcTupArgs args tys
go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
; return (L l (Present x expr')) }
- go (L _ (XTupArg nec), _) = noExtCon nec
---------------------------
-- See TcType.SyntaxOpType also for commentary
@@ -1724,7 +1722,6 @@ tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty
Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl)
res_ty }
-tcCheckRecSelId _ (XAmbiguousFieldOcc nec) _ = noExtCon nec
------------------------
tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)
@@ -1733,7 +1730,6 @@ tcInferRecSelId (Unambiguous sel (L _ lbl))
; return (expr', ty) }
tcInferRecSelId (Ambiguous _ lbl)
= ambiguousSelector lbl
-tcInferRecSelId (XAmbiguousFieldOcc nec) = noExtCon nec
------------------------
tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
@@ -1955,9 +1951,9 @@ too_many_args fun args
hang (text "Too many type arguments to" <+> text fun <> colon)
2 (sep (map pp args))
where
+ pp :: LHsExprArgIn -> SDoc
pp (HsValArg e) = ppr e
pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t
- pp (HsTypeArg _ (XHsWildCardBndrs nec)) = noExtCon nec
pp (HsArgPar _) = empty
@@ -2242,7 +2238,6 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
Unambiguous sel_name _ -> Just (x, sel_name)
Ambiguous{} -> Nothing
- XAmbiguousFieldOcc nec -> noExtCon nec
-- Look up the possible parents and selector GREs for each field
getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
@@ -2442,7 +2437,6 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
; return Nothing }
where
field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
-tcRecordField _ _ (L _ (XFieldOcc nec)) _ = noExtCon nec
checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM ()
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index c7a7f298f5..be5b4f7694 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -218,7 +218,6 @@ kcClassSigType skol_info names (HsIB { hsib_ext = sig_vars
; emitResidualTvConstraint skol_info Nothing spec_tkvs
tc_lvl wanted }
-kcClassSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec
tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
-- Does not do validity checking
@@ -271,7 +270,6 @@ tcStandaloneKindSig (L _ kisig) = case kisig of
do { kind <- tcTopLHsType kindLevelMode ksig (expectedKindInCtxt ctxt)
; checkValidType ctxt kind
; return (name, kind) }
- XStandaloneKindSig nec -> noExtCon nec
tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn
-> ContextKind -> TcM (Bool, TcType)
@@ -309,8 +307,6 @@ tc_hs_sig_type skol_info hs_sig_type ctxt_kind
; return (insolubleWC wanted, mkInvForAllTys kvs ty1) }
-tc_hs_sig_type _ (XHsImplicitBndrs nec) _ = noExtCon nec
-
tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type
-- tcTopLHsType is used for kind-checking top-level HsType where
-- we want to fully solve /all/ equalities, and report errors
@@ -334,8 +330,6 @@ tcTopLHsType mode hs_sig_type ctxt_kind
; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty])
; return final_ty}
-tcTopLHsType _ (XHsImplicitBndrs nec) _ = noExtCon nec
-
-----------------
tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])
-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause
@@ -421,7 +415,6 @@ tcHsTypeApp wc_ty kind
; ty <- zonkTcType ty
; checkValidType TypeAppCtxt ty
; return ty }
-tcHsTypeApp (XHsWildCardBndrs nec) _ = noExtCon nec
{- Note [Wildcards in visible type application]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1947,7 +1940,6 @@ kcCheckDeclHeader_cusk name flav
where
ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
| otherwise = AnyKind
-kcCheckDeclHeader_cusk _ _ (XLHsQTyVars nec) _ = noExtCon nec
-- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and
-- other kinds).
@@ -2004,8 +1996,6 @@ kcInferDeclHeader name flav
ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
| otherwise = AnyKind
-kcInferDeclHeader _ _ (XLHsQTyVars nec) _ = noExtCon nec
-
-- | Kind-check a declaration header against a standalone kind signature.
-- See Note [Arity inference in kcCheckDeclHeader_sig]
kcCheckDeclHeader_sig
@@ -2201,7 +2191,6 @@ kcCheckDeclHeader_sig kisig name flav
unifyKind (Just (HsTyVar noExtField NotPromoted v))
(tyBinderType tb)
v_ki
- XTyVarBndr nec -> noExtCon nec
-- Split the invisible binders that should become a part of 'tyConBinders'
-- rather than 'tyConResKind'.
@@ -2217,8 +2206,6 @@ kcCheckDeclHeader_sig kisig name flav
n_inst = n_sig_invis_bndrs - n_res_invis_bndrs
in splitPiTysInvisibleN n_inst sig_ki
-kcCheckDeclHeader_sig _ _ _ (XLHsQTyVars nec) _ = noExtCon nec
-
-- A quantifier from a kind signature zipped with a user-written binder for it.
data ZippedBinder =
ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn))
@@ -2709,7 +2696,6 @@ tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm))
tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)
= do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind
; new_tv tv_nm kind }
-tcHsTyVarBndr _ (XTyVarBndr nec) = noExtCon nec
-----------------
tcHsQTyVarBndr :: ContextKind
@@ -2742,8 +2728,6 @@ tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)
hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm)
-- Used for error messages only
-tcHsQTyVarBndr _ _ (XTyVarBndr nec) = noExtCon nec
-
--------------------------------------
-- Binding type/class variables in the
-- kind-checking and typechecking phases
@@ -3200,9 +3184,6 @@ tcHsPartialSigType ctxt sig_ty
; traceTc "tcHsPartialSigType" (ppr tv_prs)
; return (wcs, wcx, tv_prs, theta, tau) }
-tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec
-tcHsPartialSigType _ (XHsWildCardBndrs nec) = noExtCon nec
-
tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)
tcPartialContext hs_theta
| Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta
@@ -3342,9 +3323,6 @@ tcHsPatSigType ctxt sig_ty
-- NB: tv's Name may be fresh (in the case of newPatSigTyVar)
; return (name, tv) }
-tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec
-tcHsPatSigType _ (XHsWildCardBndrs nec) = noExtCon nec
-
tcPatSig :: Bool -- True <=> pattern binding
-> LHsSigWcType GhcRn
-> ExpSigmaType
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index 314b81faa8..8ef022edbe 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -235,7 +235,6 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
; return (MG { mg_alts = L l matches'
, mg_ext = MatchGroupTc pat_tys rhs_ty
, mg_origin = origin }) }
-tcMatches _ _ _ (XMatchGroup nec) = noExtCon nec
-------------
tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body
@@ -255,7 +254,6 @@ tcMatch ctxt pat_tys rhs_ty match
; return (Match { m_ext = noExtField
, m_ctxt = mc_what ctxt, m_pats = pats'
, m_grhss = grhss' }) }
- tc_match _ _ _ (XMatch nec) = noExtCon nec
-- For (\x -> e), tcExpr has already said "In the expression \x->e"
-- so we don't want to add "In the lambda abstraction \x->e"
@@ -280,7 +278,6 @@ tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty
mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
; return (GRHSs noExtField grhss' (L l binds')) }
-tcGRHSs _ (XGRHSs nec) _ = noExtCon nec
-------------
tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))
@@ -293,7 +290,6 @@ tcGRHS ctxt res_ty (GRHS _ guards rhs)
; return (GRHS noExtField guards' rhs') }
where
stmt_ctxt = PatGuard (mc_what ctxt)
-tcGRHS _ _ (XGRHS nec) = noExtCon nec
{-
************************************************************************
@@ -483,7 +479,6 @@ tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
; (pairs', thing) <- loop pairs
; return (ids, pairs', thing) }
; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
- loop (XParStmtBlock nec:_) = noExtCon nec
tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
, trS_bndrs = bindersMap
@@ -1060,12 +1055,9 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
}
; return (ApplicativeArgMany x stmts' ret' pat') }
- goArg _body_ty (XApplicativeArg nec, _, _) = noExtCon nec
-
get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
- get_arg_bndrs (XApplicativeArg nec) = noExtCon nec
{- Note [ApplicativeDo and constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1121,5 +1113,3 @@ checkArgs fun (MG { mg_alts = L _ (match1:matches) })
args_in_match :: LMatch GhcRn body -> Int
args_in_match (L _ (Match { m_pats = pats })) = length pats
- args_in_match (L _ (XMatch nec)) = noExtCon nec
-checkArgs _ (XMatchGroup nec) = noExtCon nec
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 0fa2b74c14..f218b4e1be 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -1017,8 +1017,6 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat'
pun), res) }
- tc_field (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) _ _
- = panic "tcConArgs"
find_field_ty :: Name -> FieldLabelString -> TcM TcType
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
index 373dd42a83..eaa0534770 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ b/compiler/GHC/Tc/Gen/Rule.hs
@@ -108,7 +108,6 @@ tcRuleDecls (HsRules { rds_src = src
; return $ HsRules { rds_ext = noExtField
, rds_src = src
, rds_rules = tc_decls } }
-tcRuleDecls (XRuleDecls nec) = noExtCon nec
tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId)
tcRule (HsRule { rd_ext = ext
@@ -180,7 +179,6 @@ tcRule (HsRule { rd_ext = ext
(qtkvs ++ tpl_ids)
, rd_lhs = mkHsDictLet lhs_binds lhs'
, rd_rhs = mkHsDictLet rhs_binds rhs' } }
-tcRule (XRuleDecl nec) = noExtCon nec
generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
-> LHsExpr GhcRn -> LHsExpr GhcRn
@@ -238,7 +236,6 @@ tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $
tcRuleTmBndrs rule_bndrs
; return (map snd tvs ++ tyvars, id : tmvars) }
-tcRuleTmBndrs (L _ (XRuleBndr nec) : _) = noExtCon nec
ruleCtxt :: FastString -> SDoc
ruleCtxt name = text "When checking the transformation rule" <+>
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index a6dfdcc2f4..cf7bd3c51d 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -258,8 +258,6 @@ isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
isCompleteHsSig (HsWC { hswc_ext = wcs
, hswc_body = HsIB { hsib_body = hs_ty } })
= null wcs && no_anon_wc hs_ty
-isCompleteHsSig (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec
-isCompleteHsSig (XHsWildCardBndrs nec) = noExtCon nec
no_anon_wc :: LHsType GhcRn -> Bool
no_anon_wc lty = go lty
@@ -300,7 +298,6 @@ no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs
where
go (UserTyVar _ _) = True
go (KindedTyVar _ _ ki) = no_anon_wc ki
- go (XTyVarBndr nec) = noExtCon nec
{- Note [Fail eagerly on bad signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -465,7 +462,6 @@ tcPatSynSig name sig_ty
mkSpecForAllTys ex $
mkPhiTy prov $
body
-tcPatSynSig _ (XHsImplicitBndrs nec) = noExtCon nec
ppr_tvs :: [TyVar] -> SDoc
ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 3de1e2063d..f60f6682d2 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -274,7 +274,6 @@ brackTy b =
(PatBr {}) -> mkTy patTyConName -- Result type is m Pat
(DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL"
(TExpBr {}) -> panic "tcUntypedBracket: Unexpected TExpBr"
- (XBracket nec) -> noExtCon nec
---------------
-- | Typechecking a pending splice from a untyped bracket
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 54b663f581..a27aab1730 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -557,7 +557,6 @@ tc_rn_src_decls ds
("Declaration splices are not "
++ "permitted inside top-level "
++ "declarations added with addTopDecls"))
- ; Just (XSpliceDecl nec, _) -> noExtCon nec
}
-- Rename TH-generated top-level declarations
; (tcg_env, th_rn_decls) <- setGblEnv tcg_env
@@ -604,7 +603,6 @@ tc_rn_src_decls ds
; return (tcg_env, tcl_env, lie2)
}
- ; Just (XSpliceDecl nec, _) -> noExtCon nec
}
}
@@ -641,7 +639,6 @@ tcRnHsBootDecls hsc_src decls
-- Check for illegal declarations
; case group_tail of
Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d
- Just (XSpliceDecl nec, _) -> noExtCon nec
Nothing -> return ()
; mapM_ (badBootDecl hsc_src "foreign") for_decls
; mapM_ (badBootDecl hsc_src "default") def_decls
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 2a21b8a61c..612348c4f3 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -201,9 +201,6 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
; let deriv_info = datafam_deriv_info ++ data_deriv_info
; return (gbl_env', inst_info, deriv_info) }
-
-tcTyClGroup (XTyClGroup nec) = noExtCon nec
-
-- Gives the kind for every TyCon that has a standalone kind signature
type KindSigEnv = NameEnv Kind
@@ -1357,10 +1354,6 @@ getInitialKind strategy
Nothing -> return AnyKind
; return [tc] }
-getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
-getInitialKind _ (FamDecl {tcdFam = XFamilyDecl nec}) = noExtCon nec
-getInitialKind _ (XTyClDecl nec) = noExtCon nec
-
get_fam_decl_initial_kind
:: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls
-> FamilyDecl GhcRn
@@ -1382,7 +1375,6 @@ get_fam_decl_initial_kind mb_parent_tycon
where
flav = getFamFlav mb_parent_tycon info
ctxt = TyFamResKindCtxt name
-get_fam_decl_initial_kind _ (XFamilyDecl nec) = noExtCon nec
-- See Note [Standalone kind signatures for associated types]
check_initial_kind_assoc_fam
@@ -1402,7 +1394,6 @@ check_initial_kind_assoc_fam cls
where
ctxt = TyFamResKindCtxt name
flav = getFamFlav (Just cls) info
-check_initial_kind_assoc_fam _ (XFamilyDecl nec) = noExtCon nec
{- Note [Standalone kind signatures for associated types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1562,9 +1553,6 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc
= case fd_info of
ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns
_ -> return ()
-kcTyClDecl (FamDecl _ (XFamilyDecl nec)) _ = noExtCon nec
-kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) _ = noExtCon nec
-kcTyClDecl (XTyClDecl nec) _ = noExtCon nec
-------------------
@@ -1633,8 +1621,6 @@ kcConDecl new_or_data res_kind (ConDeclGADT
; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)
; _ <- tcHsOpenType res_ty
; return () }
-kcConDecl _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _) = noExtCon nec
-kcConDecl _ _ (XConDecl nec) = noExtCon nec
{- Note [kcConDecls result kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2028,8 +2014,6 @@ tcTyClDecl1 _parent roles_info
meths fundeps sigs ats at_defs
; return (noDerivInfos (classTyCon clas)) }
-tcTyClDecl1 _ _ (XTyClDecl nec) = noExtCon nec
-
{- *********************************************************************
* *
@@ -2252,9 +2236,6 @@ tcDefaultAssocDecl fam_tc
suggestion = text "The arguments to" <+> quotes (ppr fam_tc)
<+> text "must all be distinct type variables"
-tcDefaultAssocDecl _ [L _ (TyFamInstDecl (HsIB _ (XFamEqn x)))] = noExtCon x
-tcDefaultAssocDecl _ [L _ (TyFamInstDecl (XHsImplicitBndrs x))] = noExtCon x
-
{- Note [Type-checking default assoc decls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2588,7 +2569,6 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
#if __GLASGOW_HASKELL__ <= 810
| otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker
#endif
-tcFamDecl1 _ (XFamilyDecl nec) = noExtCon nec
-- | Maybe return a list of Bools that say whether a type family was declared
-- injective in the corresponding type arguments. Length of the list is equal to
@@ -2737,7 +2717,6 @@ tcDataDefn err_ctxt roles_info tc_name
DataType -> return (mkDataTyConRhs data_cons)
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
-tcDataDefn _ _ _ (XHsDataDefn nec) = noExtCon nec
-------------------------
@@ -2775,9 +2754,6 @@ kcTyFamInstEqn tc_fam_tc
where
vis_arity = length (tyConVisibleTyVars tc_fam_tc)
-kcTyFamInstEqn _ (L _ (XHsImplicitBndrs nec)) = noExtCon nec
-kcTyFamInstEqn _ (L _ (HsIB _ (XFamEqn nec))) = noExtCon nec
-
--------------------------
tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
@@ -2816,8 +2792,6 @@ tcTyFamInstEqn fam_tc mb_clsinfo
(map (const Nominal) qtvs)
loc) }
-tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn"
-
{-
Kind check type patterns and kind annotate the embedded type variables.
type instance F [a] = rhs
@@ -3296,9 +3270,6 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data
; traceTc "tcConDecl 2" (ppr names)
; mapM buildOneDataCon names
}
-tcConDecl _ _ _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars nec) _ _ _ _)
- = noExtCon nec
-tcConDecl _ _ _ _ _ _ (XConDecl nec) = noExtCon nec
-- | Produce an "expected kind" for the arguments of a data/newtype.
-- If the declaration is indeed for a newtype,
@@ -4687,8 +4658,6 @@ tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =
HsIB { hsib_body = eqn }})
= tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")
(unLoc (feqn_tycon eqn))
-tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs nec))
- = noExtCon nec
tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a
tcAddDataFamInstCtxt decl
@@ -4880,7 +4849,6 @@ wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots))
text "Expected" <+> (ppr $ length tyvars) <> comma <+>
text "got" <+> (ppr $ length annots) <> colon)
2 (ppr d)
-wrongNumberOfRoles _ (L _ (XRoleAnnotDecl nec)) = noExtCon nec
illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()
@@ -4889,7 +4857,6 @@ illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _))
setSrcSpan loc $
addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$
text "they are allowed only for datatypes and classes.")
-illegalRoleAnnotDecl (L _ (XRoleAnnotDecl nec)) = noExtCon nec
needXRoleAnnotations :: TyCon -> SDoc
needXRoleAnnotations tc
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index 84278082e3..be247eed39 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -467,8 +467,6 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
= do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)
; return (insts, fam_insts, deriv_infos) }
-tcLocalInstDecl (L _ (XInstDecl nec)) = noExtCon nec
-
tcClsInstDecl :: LClsInstDecl GhcRn
-> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
-- The returned DerivInfos are for any associated data families
@@ -544,8 +542,6 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
. dfid_eqn
. unLoc) adts)
-tcClsInstDecl (L _ (XClsInstDecl nec)) = noExtCon nec
-
{-
************************************************************************
* *
@@ -788,8 +784,6 @@ tcDataFamInstDecl mb_clsinfo
= go pats (Bndr tv tcb_vis : etad_tvs)
go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs)
-tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl"
-
-----------------------
tcDataFamInstHeader
:: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn]
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 01b446c88b..6bee37fafd 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -109,8 +109,6 @@ recoverPSB (PSB { psb_id = L _ name
matcher_id = mkLocalId matcher_name $
mkSpecForAllTys [alphaTyVar] alphaTy
-recoverPSB (XPatSynBind nec) = noExtCon nec
-
{- Note [Pattern synonym error recovery]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If type inference for a pattern synonym fails, we can't continue with
@@ -194,7 +192,6 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
, mkTyVarTys ex_tvs, prov_theta, prov_evs)
(map nlHsVar args, map idType args)
pat_ty rec_fields } }
-tcInferPatSynDecl (XPatSynBind nec) = noExtCon nec
mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
-- See Note [Equality evidence in pattern synonyms]
@@ -441,7 +438,6 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
-- Why do we need tcSubType here?
-- See Note [Pattern synonyms and higher rank types]
; return (mkLHsWrap wrap $ nlHsVar arg_id) }
-tcCheckPatSynDecl (XPatSynBind nec) _ = noExtCon nec
{- [Pattern synonyms and higher rank types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -888,7 +884,6 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name
= mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
pprMatches other_mg
-tcPatSynBuilderBind (XPatSynBind nec) = noExtCon nec
tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
-- monadic only for failure
@@ -992,11 +987,9 @@ tcPatToExpr name args pat = go pat
go1 p@(AsPat {}) = notInvertible p
go1 p@(ViewPat {}) = notInvertible p
go1 p@(NPlusKPat {}) = notInvertible p
- go1 (XPat nec) = noExtCon nec
go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p
go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p
- go1 (SplicePat _ (XSplice nec)) = noExtCon nec
notInvertible p = Left (not_invertible_msg p)
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 139e416012..d67cc71150 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -510,7 +510,6 @@ exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e
exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e
-exprCtOrigin (XExpr nec) = noExtCon nec
-- | Extract a suitable CtOrigin from a MatchGroup
matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
@@ -521,17 +520,14 @@ matchesCtOrigin (MG { mg_alts = alts })
| otherwise
= Shouldn'tHappenOrigin "multi-way match"
-matchesCtOrigin (XMatchGroup nec) = noExtCon nec
-- | Extract a suitable CtOrigin from guarded RHSs
grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin
grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss
-grhssCtOrigin (XGRHSs nec) = noExtCon nec
-- | Extract a suitable CtOrigin from a list of guarded RHSs
lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin
lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e
-lGRHSCtOrigin [L _ (XGRHS nec)] = noExtCon nec
lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS"
pprCtOrigin :: CtOrigin -> SDoc
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 0154ed157e..95722733be 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -681,18 +681,11 @@ tcAddDataFamConPlaceholders inst_decls thing_inside
get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
= concatMap (get_fi_cons . unLoc) fids
- get_cons (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec
- get_cons (L _ (XInstDecl nec)) = noExtCon nec
get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
= map unLoc $ concatMap (getConNames . unLoc) cons
- get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
- FamEqn { feqn_rhs = XHsDataDefn nec }}})
- = noExtCon nec
- get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn nec))) = noExtCon nec
- get_fi_cons (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec
tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 74115d15b0..563ddff69d 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -544,7 +544,6 @@ newOverloadedLit
= newNonTrivialOverloadedLit orig lit res_ty
where
orig = LiteralOrigin lit
-newOverloadedLit (XOverLit nec) _ = noExtCon nec
-- Does not handle things that 'shortCutLit' can handle. See also
-- newOverloadedLit in GHC.Tc.Utils.Unify
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 057535d65d..7fb9fa68f0 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -121,7 +121,6 @@ hsPatType (SigPat ty _ _) = ty
hsPatType (NPat ty _ _ _) = ty
hsPatType (NPlusKPat ty _ _ _ _ _) = ty
hsPatType (CoPat _ _ _ ty) = ty
-hsPatType (XPat n) = noExtCon n
hsPatType ConPatIn{} = panic "hsPatType: ConPatIn"
hsPatType SplicePat{} = panic "hsPatType: SplicePat"
@@ -139,7 +138,6 @@ hsLitType (HsInteger _ _ ty) = ty
hsLitType (HsRat _ _ ty) = ty
hsLitType (HsFloatPrim _ _) = floatPrimTy
hsLitType (HsDoublePrim _ _) = doublePrimTy
-hsLitType (XLit nec) = noExtCon nec
-- Overloaded literals. Here mainly because it uses isIntTy etc
@@ -387,7 +385,6 @@ zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids
zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
zonkFieldOcc env (FieldOcc sel lbl)
= fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
-zonkFieldOcc _ (XFieldOcc nec) = noExtCon nec
zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
zonkEvBndrsX = mapAccumLM zonkEvBndrX
@@ -518,12 +515,6 @@ zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
= do n' <- mapIPNameTc (zonkIdBndr env) n
e' <- zonkLExpr env e
return (IPBind x n' e')
- zonk_ip_bind (XIPBind nec) = noExtCon nec
-
-zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds nec))
- = noExtCon nec
-zonkLocalBinds _ (XHsLocalBindsLR nec)
- = noExtCon nec
---------------------------------------------
zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
@@ -605,6 +596,7 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
| otherwise
= zonk_lbind env lbind -- The normal case
+ zonk_export :: ZonkEnv -> ABExport GhcTcId -> TcM (ABExport GhcTc)
zonk_export env (ABE{ abe_ext = x
, abe_wrap = wrap
, abe_poly = poly_id
@@ -618,7 +610,6 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, abe_poly = new_poly_id
, abe_mono = zonkIdOcc env mono_id
, abe_prags = new_prags })
- zonk_export _ (XABExport nec) = noExtCon nec
zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
, psb_args = details
@@ -634,9 +625,6 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
, psb_def = lpat'
, psb_dir = dir' } }
-zonk_bind _ (PatSynBind _ (XPatSynBind nec)) = noExtCon nec
-zonk_bind _ (XHsBindsLR nec) = noExtCon nec
-
zonkPatSynDetails :: ZonkEnv
-> HsPatSynDetails (Located TcId)
-> HsPatSynDetails (Located Id)
@@ -689,7 +677,6 @@ zonkMatchGroup env zBody (MG { mg_alts = L l ms
; return (MG { mg_alts = L l ms'
, mg_ext = MatchGroupTc arg_tys' res_ty'
, mg_origin = origin }) }
-zonkMatchGroup _ _ (XMatchGroup nec) = noExtCon nec
zonkMatch :: ZonkEnv
-> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
@@ -700,7 +687,6 @@ zonkMatch env zBody (L loc match@(Match { m_pats = pats
= do { (env1, new_pats) <- zonkPats env pats
; new_grhss <- zonkGRHSs env1 zBody grhss
; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
-zonkMatch _ _ (L _ (XMatch nec)) = noExtCon nec
-------------------------------------------------------------------------
zonkGRHSs :: ZonkEnv
@@ -715,10 +701,8 @@ zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do
= do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
new_rhs <- zBody env2 rhs
return (GRHS xx new_guarded new_rhs)
- zonk_grhs (XGRHS nec) = noExtCon nec
new_grhss <- mapM (wrapLocM zonk_grhs) grhss
return (GRHSs x new_grhss (L l new_binds))
-zonkGRHSs _ _ (XGRHSs nec) = noExtCon nec
{-
************************************************************************
@@ -829,7 +813,6 @@ zonkExpr env (ExplicitTuple x tup_args boxed)
; return (L l (Present x e')) }
zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t
; return (L l (Missing t')) }
- zonk_tup_arg (L _ (XTupArg nec)) = noExtCon nec
zonkExpr env (ExplicitSum args alt arity expr)
@@ -857,7 +840,6 @@ zonkExpr env (HsMultiIf ty alts)
= do { (env', guard') <- zonkStmts env zonkLExpr guard
; expr' <- zonkLExpr env' expr
; return $ GRHS x guard' expr' }
- zonk_alt (XGRHS nec) = noExtCon nec
zonkExpr env (HsLet x (L l binds) expr)
= do (new_env, new_binds) <- zonkLocalBinds env binds
@@ -1045,7 +1027,6 @@ zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
-- rules for arrows
return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
-zonk_cmd_top _ (XCmdTop nec) = noExtCon nec
-------------------------------------------------------------------------
zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
@@ -1078,8 +1059,6 @@ zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })
; e' <- zonkExpr env e
; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }
-zonkOverLit _ (XOverLit nec) = noExtCon nec
-
-------------------------------------------------------------------------
zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)
@@ -1129,12 +1108,13 @@ zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)
; return (env2
, ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)}
where
+ zonk_branch :: ZonkEnv -> ParStmtBlock GhcTcId GhcTcId
+ -> TcM (ParStmtBlock GhcTc GhcTc)
zonk_branch env1 (ParStmtBlock x stmts bndrs return_op)
= do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts
; (env3, new_return) <- zonkSyntaxExpr env2 return_op
; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)
new_return) }
- zonk_branch _ (XParStmtBlock nec) = noExtCon nec
zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
@@ -1231,15 +1211,17 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
zonk_join env Nothing = return (env, Nothing)
zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
+ get_pat :: (SyntaxExpr GhcTcId, ApplicativeArg GhcTcId) -> LPat GhcTcId
get_pat (_, ApplicativeArgOne _ pat _ _ _) = pat
get_pat (_, ApplicativeArgMany _ _ _ pat) = pat
- get_pat (_, XApplicativeArg nec) = noExtCon nec
+ replace_pat :: LPat GhcTcId
+ -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+ -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
replace_pat pat (op, ApplicativeArgOne x _ a isBody fail_op)
= (op, ApplicativeArgOne x pat a isBody fail_op)
replace_pat pat (op, ApplicativeArgMany x a b _)
= (op, ApplicativeArgMany x a b pat)
- replace_pat _ (_, XApplicativeArg nec) = noExtCon nec
zonk_args env args
= do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
@@ -1264,9 +1246,6 @@ zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
= do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
; new_ret <- zonkExpr env1 ret
; return (ApplicativeArgMany x new_stmts new_ret pat) }
- zonk_arg _ (XApplicativeArg nec) = noExtCon nec
-
-zonkStmt _ _ (XStmtLR nec) = noExtCon nec
-------------------------------------------------------------------------
zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)
@@ -1506,11 +1485,11 @@ zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
, rd_lhs = new_lhs
, rd_rhs = new_rhs } }
where
+ zonk_tm_bndr :: ZonkEnv -> LRuleBndr GhcTcId -> TcM (ZonkEnv, LRuleBndr GhcTcId)
zonk_tm_bndr env (L l (RuleBndr x (L loc v)))
= do { (env', v') <- zonk_it env v
; return (env', L l (RuleBndr x (L loc v'))) }
zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
- zonk_tm_bndr _ (L _ (XRuleBndr nec)) = noExtCon nec
zonk_it env v
| isId v = do { v' <- zonkIdBndr env v
@@ -1520,7 +1499,6 @@ zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
-- DV: used to be return (env,v) but that is plain
-- wrong because we may need to go inside the kind
-- of v and zonk there!
-zonkRule _ (XRuleDecl nec) = noExtCon nec
{-
************************************************************************
View Lorry Controller Status