summaryrefslogtreecommitdiff
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
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.
-rw-r--r--compiler/GHC/Driver/Main.hs1
-rw-r--r--compiler/GHC/Hs/Binds.hs28
-rw-r--r--compiler/GHC/Hs/Decls.hs111
-rw-r--r--compiler/GHC/Hs/Expr.hs52
-rw-r--r--compiler/GHC/Hs/Extension.hs33
-rw-r--r--compiler/GHC/Hs/ImpExp.hs7
-rw-r--r--compiler/GHC/Hs/Lit.hs9
-rw-r--r--compiler/GHC/Hs/Pat.hs5
-rw-r--r--compiler/GHC/Hs/Types.hs38
-rw-r--r--compiler/GHC/Hs/Utils.hs22
-rw-r--r--compiler/GHC/HsToCore.hs1
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs6
-rw-r--r--compiler/GHC/HsToCore/Binds.hs3
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs28
-rw-r--r--compiler/GHC/HsToCore/Docs.hs8
-rw-r--r--compiler/GHC/HsToCore/Expr.hs7
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs2
-rw-r--r--compiler/GHC/HsToCore/GuardedRHSs.hs4
-rw-r--r--compiler/GHC/HsToCore/ListComp.hs8
-rw-r--r--compiler/GHC/HsToCore/Match.hs3
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs2
-rw-r--r--compiler/GHC/HsToCore/PmCheck.hs5
-rw-r--r--compiler/GHC/HsToCore/Quote.hs71
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs46
-rw-r--r--compiler/GHC/Rename/Bind.hs17
-rw-r--r--compiler/GHC/Rename/Expr.hs29
-rw-r--r--compiler/GHC/Rename/Fixity.hs1
-rw-r--r--compiler/GHC/Rename/HsType.hs12
-rw-r--r--compiler/GHC/Rename/Module.hs41
-rw-r--r--compiler/GHC/Rename/Names.hs8
-rw-r--r--compiler/GHC/Rename/Pat.hs2
-rw-r--r--compiler/GHC/Rename/Splice.hs9
-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
-rw-r--r--compiler/GHC/ThToHs.hs2
-rw-r--r--compiler/main/HscStats.hs5
-rw-r--r--compiler/parser/RdrHsSyn.hs3
-rw-r--r--testsuite/tests/ghc-api/annotations/stringSource.hs1
m---------utils/haddock0
57 files changed, 106 insertions, 693 deletions
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index eb0996666f..cb441855d9 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -992,7 +992,6 @@ hscCheckSafeImports tcg_env = do
mkPlainWarnMsg dflags loc $
text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell"
- warnRules _ (L _ (XRuleDecl nec)) = noExtCon nec
-- | Validate that safe imported modules are actually safe. For modules in the
-- HomePackage (the package the module we are compiling in resides) this just
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 1471227528..54718d289f 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -94,7 +94,7 @@ data HsLocalBindsLR idL idR
-- ^ Empty Local Bindings
| XHsLocalBindsLR
- (XXHsLocalBindsLR idL idR)
+ !(XXHsLocalBindsLR idL idR)
type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExtField
type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExtField
@@ -126,7 +126,7 @@ data HsValBindsLR idL idR
-- After renaming RHS; idR can be Name or Id Dependency analysed,
-- later bindings in the list may depend on earlier ones.
| XValBindsLR
- (XXValBindsLR idL idR)
+ !(XXValBindsLR idL idR)
-- ---------------------------------------------------------------------
-- Deal with ValBindsOut
@@ -312,7 +312,7 @@ data HsBindLR idL idR
-- For details on above see note [Api annotations] in ApiAnnotation
- | XHsBindsLR (XXHsBindsLR idL idR)
+ | XHsBindsLR !(XXHsBindsLR idL idR)
data NPatBindTc = NPatBindTc {
pat_fvs :: NameSet, -- ^ Free variables
@@ -354,7 +354,7 @@ data ABExport p
-- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
, abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
}
- | XABExport (XXABExport p)
+ | XABExport !(XXABExport p)
type instance XABE (GhcPass p) = NoExtField
type instance XXABExport (GhcPass p) = NoExtCon
@@ -377,7 +377,7 @@ data PatSynBind idL idR
psb_def :: LPat idR, -- ^ Right-hand side
psb_dir :: HsPatSynDir idR -- ^ Directionality
}
- | XPatSynBind (XXPatSynBind idL idR)
+ | XPatSynBind !(XXPatSynBind idL idR)
type instance XPSB (GhcPass idL) GhcPs = NoExtField
type instance XPSB (GhcPass idL) GhcRn = NameSet
@@ -623,7 +623,6 @@ instance (OutputableBndrId pl, OutputableBndrId pr)
ppr (HsValBinds _ bs) = ppr bs
ppr (HsIPBinds _ bs) = ppr bs
ppr (EmptyLocalBinds _) = empty
- ppr (XHsLocalBindsLR x) = ppr x
instance (OutputableBndrId pl, OutputableBndrId pr)
=> Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where
@@ -750,14 +749,12 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, text "Binds:" <+> pprLHsBinds val_binds
, pprIfTc @idR (text "Evidence:" <+> ppr ev_binds)
]
-ppr_monobind (XHsBindsLR x) = ppr x
instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> text "<=" <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ]
- ppr (XABExport x) = ppr x
instance (OutputableBndrId l, OutputableBndrId r,
Outputable (XXPatSynBind (GhcPass l) (GhcPass r)))
@@ -780,7 +777,6 @@ instance (OutputableBndrId l, OutputableBndrId r,
ImplicitBidirectional -> ppr_simple equals
ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$
(nest 2 $ pprFunBind mg)
- ppr (XPatSynBind x) = ppr x
pprTicks :: SDoc -> SDoc -> SDoc
-- Print stuff about ticks only when -dppr-debug is on, to avoid
@@ -807,7 +803,7 @@ data HsIPBinds id
[LIPBind id]
-- TcEvBinds -- Only in typechecker output; binds
-- -- uses of the implicit parameters
- | XHsIPBinds (XXHsIPBinds id)
+ | XHsIPBinds !(XXHsIPBinds id)
type instance XIPBinds GhcPs = NoExtField
type instance XIPBinds GhcRn = NoExtField
@@ -819,11 +815,9 @@ type instance XXHsIPBinds (GhcPass p) = NoExtCon
isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool
isEmptyIPBindsPR (IPBinds _ is) = null is
-isEmptyIPBindsPR (XHsIPBinds _) = True
isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool
isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds
-isEmptyIPBindsTc (XHsIPBinds _) = True
-- | Located Implicit Parameter Binding
type LIPBind id = Located (IPBind id)
@@ -847,7 +841,7 @@ data IPBind id
(XCIPBind id)
(Either (Located HsIPName) (IdP id))
(LHsExpr id)
- | XIPBind (XXIPBind id)
+ | XIPBind !(XXIPBind id)
type instance XCIPBind (GhcPass p) = NoExtField
type instance XXIPBind (GhcPass p) = NoExtCon
@@ -856,14 +850,12 @@ instance OutputableBndrId p
=> Outputable (HsIPBinds (GhcPass p)) where
ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)
$$ whenPprDebug (pprIfTc @p $ ppr ds)
- ppr (XHsIPBinds x) = ppr x
instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where
ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip
Right id -> pprBndr LetBind id
- ppr (XIPBind x) = ppr x
{-
************************************************************************
@@ -1030,7 +1022,7 @@ data Sig pass
SourceText
(Located [Located (IdP pass)])
(Maybe (Located (IdP pass)))
- | XSig (XXSig pass)
+ | XSig !(XXSig pass)
type instance XTypeSig (GhcPass p) = NoExtField
type instance XPatSynSig (GhcPass p) = NoExtField
@@ -1050,7 +1042,7 @@ type LFixitySig pass = Located (FixitySig pass)
-- | Fixity Signature
data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity
- | XFixitySig (XXFixitySig pass)
+ | XFixitySig !(XXFixitySig pass)
type instance XFixitySig (GhcPass p) = NoExtField
type instance XXFixitySig (GhcPass p) = NoExtCon
@@ -1190,14 +1182,12 @@ ppr_sig (CompleteMatchSig _ src cs mty)
<+> opt_sig)
where
opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
-ppr_sig (XSig x) = ppr x
instance OutputableBndrId p
=> Outputable (FixitySig (GhcPass p)) where
ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops]
where
pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
- ppr (XFixitySig x) = ppr x
pragBrackets :: SDoc -> SDoc
pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 8a5cc16fbe..c3388b6362 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -154,7 +154,7 @@ data HsDecl p
-- (Includes quasi-quotes)
| DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration
| RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration
- | XHsDecl (XXHsDecl p)
+ | XHsDecl !(XXHsDecl p)
type instance XTyClD (GhcPass _) = NoExtField
type instance XInstD (GhcPass _) = NoExtField
@@ -248,7 +248,7 @@ data HsGroup p
hs_docs :: [LDocDecl]
}
- | XHsGroup (XXHsGroup p)
+ | XHsGroup !(XXHsGroup p)
type instance XCHsGroup (GhcPass _) = NoExtField
type instance XXHsGroup (GhcPass _) = NoExtCon
@@ -281,7 +281,6 @@ hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =
| L _ ClassDecl{tcdSigs = sigs} <- tyClGroupTyClDecls tyclds
, L loc (FixSig _ sig) <- sigs
]
-hsGroupTopLevelFixitySigs (XHsGroup nec) = noExtCon nec
appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)
-> HsGroup (GhcPass p)
@@ -324,7 +323,6 @@ appendGroups
hs_warnds = warnds1 ++ warnds2,
hs_ruleds = rulds1 ++ rulds2,
hs_docs = docs1 ++ docs2 }
-appendGroups _ _ = panic "appendGroups"
instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where
ppr (TyClD _ dcl) = ppr dcl
@@ -341,7 +339,6 @@ instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where
ppr (SpliceD _ dd) = ppr dd
ppr (DocD _ doc) = ppr doc
ppr (RoleAnnotD _ ra) = ppr ra
- ppr (XHsDecl x) = ppr x
instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where
ppr (HsGroup { hs_valds = val_decls,
@@ -376,7 +373,6 @@ instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where
vcat_mb _ [] = empty
vcat_mb gap (Nothing : ds) = vcat_mb gap ds
vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds
- ppr (XHsGroup x) = ppr x
-- | Located Splice Declaration
type LSpliceDecl pass = Located (SpliceDecl pass)
@@ -387,7 +383,7 @@ data SpliceDecl p
(XSpliceDecl p)
(Located (HsSplice p))
SpliceExplicitFlag
- | XSpliceDecl (XXSpliceDecl p)
+ | XSpliceDecl !(XXSpliceDecl p)
type instance XSpliceDecl (GhcPass _) = NoExtField
type instance XXSpliceDecl (GhcPass _) = NoExtCon
@@ -395,7 +391,6 @@ type instance XXSpliceDecl (GhcPass _) = NoExtCon
instance OutputableBndrId p
=> Outputable (SpliceDecl (GhcPass p)) where
ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f
- ppr (XSpliceDecl x) = ppr x
{-
************************************************************************
@@ -604,7 +599,7 @@ data TyClDecl pass
-- 'ApiAnnotation.AnnRarrow'
-- For details on above see note [Api annotations] in ApiAnnotation
- | XTyClDecl (XXTyClDecl pass)
+ | XTyClDecl !(XXTyClDecl pass)
type LHsFunDep pass = Located (FunDep (Located (IdP pass)))
@@ -707,17 +702,12 @@ tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p))
tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
(HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) })
= ln
-tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn nec)))
- = noExtCon nec
-tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs nec))
- = noExtCon nec
tyClDeclLName :: TyClDecl (GhcPass p) -> Located (IdP (GhcPass p))
tyClDeclLName (FamDecl { tcdFam = fd }) = familyDeclLName fd
tyClDeclLName (SynDecl { tcdLName = ln }) = ln
tyClDeclLName (DataDecl { tcdLName = ln }) = ln
tyClDeclLName (ClassDecl { tcdLName = ln }) = ln
-tyClDeclLName (XTyClDecl nec) = noExtCon nec
tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName = unLoc . tyClDeclLName
@@ -756,8 +746,6 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
= hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs)
hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
-hsDeclHasCusk (FamDecl { tcdFam = XFamilyDecl nec }) = noExtCon nec
-hsDeclHasCusk (XTyClDecl nec) = noExtCon nec
-- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -793,8 +781,6 @@ instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where
<+> pp_vanilla_decl_head lclas tyvars fixity context
<+> pprFundeps (map unLoc fds)
- ppr (XTyClDecl x) = ppr x
-
instance OutputableBndrId p
=> Outputable (TyClGroup (GhcPass p)) where
ppr (TyClGroup { group_tyclds = tyclds
@@ -808,7 +794,6 @@ instance OutputableBndrId p
ppr tyclds $$
ppr roles $$
ppr instds
- ppr (XTyClGroup x) = ppr x
pp_vanilla_decl_head :: (OutputableBndrId p)
=> Located (IdP (GhcPass p))
@@ -830,20 +815,14 @@ pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context
| otherwise = hsep [ pprPrefixOcc (unLoc thing)
, hsep (map (ppr.unLoc) (varl:varsr))]
pp_tyvars [] = pprPrefixOcc (unLoc thing)
-pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x
pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc
pprTyClDeclFlavour (ClassDecl {}) = text "class"
pprTyClDeclFlavour (SynDecl {}) = text "type"
pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})
= pprFlavour info <+> text "family"
-pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl nec })
- = noExtCon nec
pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })
= ppr nd
-pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x })
- = ppr x
-pprTyClDeclFlavour (XTyClDecl x) = ppr x
{- Note [CUSKs: complete user-supplied kind signatures]
@@ -972,7 +951,7 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis]
, group_roles :: [LRoleAnnotDecl pass]
, group_kisigs :: [LStandaloneKindSig pass]
, group_instds :: [LInstDecl pass] }
- | XTyClGroup (XXTyClGroup pass)
+ | XTyClGroup !(XXTyClGroup pass)
type instance XCTyClGroup (GhcPass _) = NoExtField
type instance XXTyClGroup (GhcPass _) = NoExtCon
@@ -1081,7 +1060,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig]
-- ^ - 'ApiAnnotation.AnnKeywordId' :
-- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',
-- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual'
- | XFamilyResultSig (XXFamilyResultSig pass)
+ | XFamilyResultSig !(XXFamilyResultSig pass)
-- For details on above see note [Api annotations] in ApiAnnotation
@@ -1106,7 +1085,7 @@ data FamilyDecl pass = FamilyDecl
, fdResultSig :: LFamilyResultSig pass -- result signature
, fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann
}
- | XFamilyDecl (XXFamilyDecl pass)
+ | XFamilyDecl !(XXFamilyDecl pass)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
-- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily',
-- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP',
@@ -1150,7 +1129,6 @@ data FamilyInfo pass
familyDeclLName :: FamilyDecl (GhcPass p) -> Located (IdP (GhcPass p))
familyDeclLName (FamilyDecl { fdLName = n }) = n
-familyDeclLName (XFamilyDecl nec) = noExtCon nec
familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)
familyDeclName = unLoc . familyDeclLName
@@ -1162,8 +1140,6 @@ famResultKindSignature (TyVarSig _ bndr) =
case unLoc bndr of
UserTyVar _ _ -> Nothing
KindedTyVar _ _ ki -> Just ki
- XTyVarBndr nec -> noExtCon nec
-famResultKindSignature (XFamilyResultSig nec) = noExtCon nec
-- | Maybe return name of the result type variable
resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))
@@ -1196,7 +1172,6 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
NoSig _ -> empty
KindSig _ kind -> dcolon <+> ppr kind
TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr
- XFamilyResultSig nec -> noExtCon nec
pp_inj = case mb_inj of
Just (L _ (InjectivityAnn lhs rhs)) ->
hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
@@ -1208,7 +1183,6 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
Nothing -> text ".."
Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )
_ -> (empty, empty)
-pprFamilyDecl _ (XFamilyDecl nec) = noExtCon nec
pprFlavour :: FamilyInfo pass -> SDoc
pprFlavour DataFamily = text "data"
@@ -1259,7 +1233,7 @@ data HsDataDefn pass -- The payload of a data type defn
-- For details on above see note [Api annotations] in ApiAnnotation
}
- | XHsDataDefn (XXHsDataDefn pass)
+ | XHsDataDefn !(XXHsDataDefn pass)
type instance XCHsDataDefn (GhcPass _) = NoExtField
@@ -1300,7 +1274,7 @@ data HsDerivingClause pass
--
-- should produce a derived instance for @C [a] (T b)@.
}
- | XHsDerivingClause (XXHsDerivingClause pass)
+ | XHsDerivingClause !(XXHsDerivingClause pass)
type instance XCHsDerivingClause (GhcPass _) = NoExtField
type instance XXHsDerivingClause (GhcPass _) = NoExtCon
@@ -1327,7 +1301,6 @@ instance OutputableBndrId p
case dcs of
Just (L _ via@ViaStrategy{}) -> (empty, ppr via)
_ -> (ppDerivStrategy dcs, empty)
- ppr (XHsDerivingClause x) = ppr x
-- | Located Standalone Kind Signature
type LStandaloneKindSig pass = Located (StandaloneKindSig pass)
@@ -1336,14 +1309,13 @@ data StandaloneKindSig pass
= StandaloneKindSig (XStandaloneKindSig pass)
(Located (IdP pass)) -- Why a single binder? See #16754
(LHsSigType pass) -- Why not LHsSigWcType? See Note [Wildcards in standalone kind signatures]
- | XStandaloneKindSig (XXStandaloneKindSig pass)
+ | XStandaloneKindSig !(XXStandaloneKindSig pass)
type instance XStandaloneKindSig (GhcPass p) = NoExtField
type instance XXStandaloneKindSig (GhcPass p) = NoExtCon
standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)
standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname
-standaloneKindSigName (XStandaloneKindSig nec) = noExtCon nec
{- Note [Wildcards in standalone kind signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1442,7 +1414,7 @@ data ConDecl pass
, con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
}
- | XConDecl (XXConDecl pass)
+ | XConDecl !(XXConDecl pass)
type instance XConDeclGADT (GhcPass _) = NoExtField
type instance XConDeclH98 (GhcPass _) = NoExtField
@@ -1492,7 +1464,6 @@ type HsConDeclDetails pass
getConNames :: ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))]
getConNames ConDeclH98 {con_name = name} = [name]
getConNames ConDeclGADT {con_names = names} = names
-getConNames (XConDecl nec) = noExtCon nec
getConArgs :: ConDecl pass -> HsConDeclDetails pass
getConArgs d = con_args d
@@ -1529,7 +1500,6 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context
Nothing -> empty
Just kind -> dcolon <+> ppr kind
pp_derivings (L _ ds) = vcat (map ppr ds)
-pp_data_defn _ (XHsDataDefn x) = ppr x
instance OutputableBndrId p
=> Outputable (HsDataDefn (GhcPass p)) where
@@ -1539,7 +1509,6 @@ instance OutputableBndrId p
=> Outputable (StandaloneKindSig (GhcPass p)) where
ppr (StandaloneKindSig _ v ki)
= text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki
- ppr (XStandaloneKindSig nec) = noExtCon nec
instance Outputable NewOrData where
ppr NewType = text "newtype"
@@ -1585,8 +1554,6 @@ pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars
ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)
ppr_arrow_chain [] = empty
-pprConDecl (XConDecl x) = ppr x
-
ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc
ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
@@ -1731,7 +1698,7 @@ data FamEqn pass rhs
}
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
- | XFamEqn (XXFamEqn pass rhs)
+ | XFamEqn !(XXFamEqn pass rhs)
-- For details on above see note [Api annotations] in ApiAnnotation
@@ -1766,7 +1733,7 @@ data ClsInstDecl pass
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
-- For details on above see note [Api annotations] in ApiAnnotation
- | XClsInstDecl (XXClsInstDecl pass)
+ | XClsInstDecl !(XXClsInstDecl pass)
type instance XCClsInstDecl (GhcPass _) = NoExtField
type instance XXClsInstDecl (GhcPass _) = NoExtCon
@@ -1787,7 +1754,7 @@ data InstDecl pass -- Both class and family instances
| TyFamInstD -- type family instance
{ tfid_ext :: XTyFamInstD pass
, tfid_inst :: TyFamInstDecl pass }
- | XInstDecl (XXInstDecl pass)
+ | XInstDecl !(XXInstDecl pass)
type instance XClsInstD (GhcPass _) = NoExtField
type instance XDataFamInstD (GhcPass _) = NoExtField
@@ -1819,8 +1786,6 @@ ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon
, feqn_fixity = fixity
, feqn_rhs = rhs }})
= pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs
-ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x
-ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x
instance OutputableBndrId p
=> Outputable (DataFamInstDecl (GhcPass p)) where
@@ -1840,22 +1805,10 @@ pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
<+> pprHsFamInstLHS tycon bndrs pats fixity ctxt
-- pp_data_defn pretty-prints the kind sig. See #14817.
-pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x)))
- = ppr x
-pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x))
- = ppr x
-
pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc
pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})
= ppr nd
-pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
- FamEqn { feqn_rhs = XHsDataDefn x}}})
- = ppr x
-pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x)))
- = ppr x
-pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x))
- = ppr x
pprHsFamInstLHS :: (OutputableBndrId p)
=> IdP (GhcPass p)
@@ -1897,7 +1850,6 @@ instance OutputableBndrId p
where
top_matter = text "instance" <+> ppOverlapPragma mbOverlap
<+> ppr inst_ty
- ppr (XClsInstDecl x) = ppr x
ppDerivStrategy :: OutputableBndrId p
=> Maybe (LDerivStrategy (GhcPass p)) -> SDoc
@@ -1924,7 +1876,6 @@ instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where
ppr (ClsInstD { cid_inst = decl }) = ppr decl
ppr (TyFamInstD { tfid_inst = decl }) = ppr decl
ppr (DataFamInstD { dfid_inst = decl }) = ppr decl
- ppr (XInstDecl x) = ppr x
-- Extract the declarations of associated data types from an instance
@@ -1932,12 +1883,11 @@ instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)]
instDeclDataFamInsts inst_decls
= concatMap do_one inst_decls
where
+ do_one :: LInstDecl (GhcPass p) -> [DataFamInstDecl (GhcPass p)]
do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))
= map unLoc fam_insts
do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst]
do_one (L _ (TyFamInstD {})) = []
- do_one (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec
- do_one (L _ (XInstDecl nec)) = noExtCon nec
{-
************************************************************************
@@ -1974,7 +1924,7 @@ data DerivDecl pass = DerivDecl
-- For details on above see note [Api annotations] in ApiAnnotation
}
- | XDerivDecl (XXDerivDecl pass)
+ | XDerivDecl !(XXDerivDecl pass)
type instance XCDerivDecl (GhcPass _) = NoExtField
type instance XXDerivDecl (GhcPass _) = NoExtCon
@@ -1989,7 +1939,6 @@ instance OutputableBndrId p
, text "instance"
, ppOverlapPragma o
, ppr ty ]
- ppr (XDerivDecl x) = ppr x
{-
************************************************************************
@@ -2075,7 +2024,7 @@ data DefaultDecl pass
-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | XDefaultDecl (XXDefaultDecl pass)
+ | XDefaultDecl !(XXDefaultDecl pass)
type instance XCDefaultDecl (GhcPass _) = NoExtField
type instance XXDefaultDecl (GhcPass _) = NoExtCon
@@ -2084,7 +2033,6 @@ instance OutputableBndrId p
=> Outputable (DefaultDecl (GhcPass p)) where
ppr (DefaultDecl _ tys)
= text "default" <+> parens (interpp'SP tys)
- ppr (XDefaultDecl x) = ppr x
{-
************************************************************************
@@ -2122,7 +2070,7 @@ data ForeignDecl pass
-- 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
- | XForeignDecl (XXForeignDecl pass)
+ | XForeignDecl !(XXForeignDecl pass)
{-
In both ForeignImport and ForeignExport:
@@ -2196,7 +2144,6 @@ instance OutputableBndrId p
ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =
hang (text "foreign export" <+> ppr fexport <+> ppr n)
2 (dcolon <+> ppr ty)
- ppr (XForeignDecl x) = ppr x
instance Outputable ForeignImport where
ppr (CImport cconv safety mHeader spec (L _ srcText)) =
@@ -2246,7 +2193,7 @@ type LRuleDecls pass = Located (RuleDecls pass)
data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass
, rds_src :: SourceText
, rds_rules :: [LRuleDecl pass] }
- | XRuleDecls (XXRuleDecls pass)
+ | XRuleDecls !(XXRuleDecls pass)
type instance XCRuleDecls (GhcPass _) = NoExtField
type instance XXRuleDecls (GhcPass _) = NoExtCon
@@ -2277,7 +2224,7 @@ data RuleDecl pass
-- 'ApiAnnotation.AnnClose',
-- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',
-- 'ApiAnnotation.AnnEqual',
- | XRuleDecl (XXRuleDecl pass)
+ | XRuleDecl !(XXRuleDecl pass)
data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS
deriving Data
@@ -2298,7 +2245,7 @@ type LRuleBndr pass = Located (RuleBndr pass)
data RuleBndr pass
= RuleBndr (XCRuleBndr pass) (Located (IdP pass))
| RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass)
- | XRuleBndr (XXRuleBndr pass)
+ | XRuleBndr !(XXRuleBndr pass)
-- ^
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'
@@ -2320,7 +2267,6 @@ instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where
, rds_rules = rules })
= pprWithSourceText st (text "{-# RULES")
<+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"
- ppr (XRuleDecls x) = ppr x
instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where
ppr (HsRule { rd_name = name
@@ -2338,12 +2284,10 @@ instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where
pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot
pp_forall_tm Nothing | null tms = empty
pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot
- ppr (XRuleDecl x) = ppr x
instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where
ppr (RuleBndr _ name) = ppr name
ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)
- ppr (XRuleBndr x) = ppr x
{-
************************************************************************
@@ -2393,7 +2337,7 @@ data WarnDecls pass = Warnings { wd_ext :: XWarnings pass
, wd_src :: SourceText
, wd_warnings :: [LWarnDecl pass]
}
- | XWarnDecls (XXWarnDecls pass)
+ | XWarnDecls !(XXWarnDecls pass)
type instance XWarnings (GhcPass _) = NoExtField
type instance XXWarnDecls (GhcPass _) = NoExtCon
@@ -2403,7 +2347,7 @@ type LWarnDecl pass = Located (WarnDecl pass)
-- | Warning pragma Declaration
data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt
- | XWarnDecl (XXWarnDecl pass)
+ | XWarnDecl !(XXWarnDecl pass)
type instance XWarning (GhcPass _) = NoExtField
type instance XXWarnDecl (GhcPass _) = NoExtCon
@@ -2414,14 +2358,12 @@ instance OutputableBndr (IdP (GhcPass p))
ppr (Warnings _ (SourceText src) decls)
= text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"
- ppr (XWarnDecls x) = ppr x
instance OutputableBndr (IdP (GhcPass p))
=> Outputable (WarnDecl (GhcPass p)) where
ppr (Warning _ thing txt)
= hsep ( punctuate comma (map ppr thing))
<+> ppr txt
- ppr (XWarnDecl x) = ppr x
{-
************************************************************************
@@ -2445,7 +2387,7 @@ data AnnDecl pass = HsAnnotation
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
- | XAnnDecl (XXAnnDecl pass)
+ | XAnnDecl !(XXAnnDecl pass)
type instance XHsAnnotation (GhcPass _) = NoExtField
type instance XXAnnDecl (GhcPass _) = NoExtCon
@@ -2453,7 +2395,6 @@ type instance XXAnnDecl (GhcPass _) = NoExtCon
instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where
ppr (HsAnnotation _ _ provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
- ppr (XAnnDecl x) = ppr x
-- | Annotation Provenance
data AnnProvenance name = ValueAnnProvenance (Located name)
@@ -2498,7 +2439,7 @@ data RoleAnnotDecl pass
-- 'ApiAnnotation.AnnRole'
-- For details on above see note [Api annotations] in ApiAnnotation
- | XRoleAnnotDecl (XXRoleAnnotDecl pass)
+ | XRoleAnnotDecl !(XXRoleAnnotDecl pass)
type instance XCRoleAnnotDecl (GhcPass _) = NoExtField
type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon
@@ -2511,8 +2452,6 @@ instance OutputableBndr (IdP (GhcPass p))
where
pp_role Nothing = underscore
pp_role (Just r) = ppr r
- ppr (XRoleAnnotDecl x) = ppr x
roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)
roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name
-roleAnnotDeclName (XRoleAnnotDecl nec) = noExtCon nec
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 478ed58364..f9d4c559f0 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -552,7 +552,7 @@ data HsExpr p
-- Expressions annotated with pragmas, written as {-# ... #-}
| HsPragE (XPragE p) (HsPragE p) (LHsExpr p)
- | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor
+ | XExpr !(XXExpr p) -- Note [Trees that Grow] extension constructor
-- | Extra data fields for a 'RecordCon', added by the type checker
@@ -705,7 +705,7 @@ data HsPragE p
-- Source text for the four integers used in the span.
-- See note [Pragma source text] in GHC.Types.Basic
- | XHsPragE (XXPragE p)
+ | XHsPragE !(XXPragE p)
type instance XSCC (GhcPass _) = NoExtField
type instance XCoreAnn (GhcPass _) = NoExtField
@@ -727,7 +727,7 @@ type LHsTupArg id = Located (HsTupArg id)
data HsTupArg id
= Present (XPresent id) (LHsExpr id) -- ^ The argument
| Missing (XMissing id) -- ^ The argument is missing, but this is its type
- | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point
+ | XTupArg !(XXTupArg id) -- ^ Note [Trees that Grow] extension point
type instance XPresent (GhcPass _) = NoExtField
@@ -988,7 +988,6 @@ ppr_expr (ExplicitTuple _ exprs boxity)
ppr_tup_args [] = []
ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es
ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es
- ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es
punc (Present {} : _) = comma <> space
punc (Missing {} : _) = comma
@@ -1066,8 +1065,6 @@ ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc
ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
= hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
-ppr_expr (HsProc _ pat (L _ (XCmdTop x)))
- = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x]
ppr_expr (HsStatic _ e)
= hsep [text "static", ppr e]
@@ -1086,8 +1083,10 @@ ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)
ppr_expr (HsRecFld _ f) = ppr f
ppr_expr (XExpr x) = case ghcPass @p of
+#if __GLASGOW_HASKELL__ < 811
GhcPs -> ppr x
GhcRn -> ppr x
+#endif
GhcTc -> case x of
HsWrap co_fn e -> pprHsWrapper co_fn (\parens -> if parens then pprExpr e
else pprExpr e)
@@ -1251,7 +1250,6 @@ instance Outputable (HsPragE (GhcPass p)) where
<+> char '-'
<+> pprWithSourceText s3 (ppr v3) <+> char ':' <+> pprWithSourceText s4 (ppr v4)
<+> text "#-}"
- ppr (XHsPragE x) = noExtCon x
{-
************************************************************************
@@ -1354,7 +1352,7 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
- | XCmd (XXCmd id) -- Note [Trees that Grow] extension point
+ | XCmd !(XXCmd id) -- Note [Trees that Grow] extension point
type instance XCmdArrApp GhcPs = NoExtField
type instance XCmdArrApp GhcRn = NoExtField
@@ -1398,7 +1396,7 @@ type LHsCmdTop p = Located (HsCmdTop p)
data HsCmdTop p
= HsCmdTop (XCmdTop p)
(LHsCmd p)
- | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point
+ | XCmdTop !(XXCmdTop p) -- Note [Trees that Grow] extension point
data CmdTopTc
= CmdTopTc Type -- Nested tuple of inputs on the command's stack
@@ -1496,15 +1494,16 @@ ppr_cmd (HsCmdArrForm _ op _ _ args)
= hang (text "(|" <+> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
ppr_cmd (XCmd x) = case ghcPass @p of
+#if __GLASGOW_HASKELL__ < 811
GhcPs -> ppr x
GhcRn -> ppr x
+#endif
GhcTc -> case x of
HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd))
pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc
pprCmdArg (HsCmdTop _ cmd)
= ppr_lcmd cmd
-pprCmdArg (XCmdTop x) = ppr x
instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where
ppr = pprCmdArg
@@ -1549,7 +1548,7 @@ data MatchGroup p body
-- The type is the type of the entire group
-- t1 -> ... -> tn -> tr
-- where there are n patterns
- | XMatchGroup (XXMatchGroup p body)
+ | XMatchGroup !(XXMatchGroup p body)
data MatchGroupTc
= MatchGroupTc
@@ -1577,7 +1576,7 @@ data Match p body
m_pats :: [LPat p], -- The patterns
m_grhss :: (GRHSs p body)
}
- | XMatch (XXMatch p body)
+ | XMatch !(XXMatch p body)
type instance XCMatch (GhcPass _) b = NoExtField
type instance XXMatch (GhcPass _) b = NoExtCon
@@ -1647,11 +1646,9 @@ matchGroupArity :: MatchGroup (GhcPass id) body -> Arity
matchGroupArity (MG { mg_alts = alts })
| L _ (alt1:_) <- alts = length (hsLMatchPats alt1)
| otherwise = panic "matchGroupArity"
-matchGroupArity (XMatchGroup nec) = noExtCon nec
hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]
hsLMatchPats (L _ (Match { m_pats = pats })) = pats
-hsLMatchPats (L _ (XMatch nec)) = noExtCon nec
-- | Guarded Right-Hand Sides
--
@@ -1669,7 +1666,7 @@ data GRHSs p body
grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs
grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause
}
- | XGRHSs (XXGRHSs p body)
+ | XGRHSs !(XXGRHSs p body)
type instance XCGRHSs (GhcPass _) b = NoExtField
type instance XXGRHSs (GhcPass _) b = NoExtCon
@@ -1681,7 +1678,7 @@ type LGRHS id body = Located (GRHS id body)
data GRHS p body = GRHS (XCGRHS p body)
[GuardLStmt p] -- Guards
body -- Right hand side
- | XGRHS (XXGRHS p body)
+ | XGRHS !(XXGRHS p body)
type instance XCGRHS (GhcPass _) b = NoExtField
type instance XXGRHS (GhcPass _) b = NoExtCon
@@ -1693,7 +1690,6 @@ pprMatches :: (OutputableBndrId idR, Outputable body)
pprMatches MG { mg_alts = matches }
= vcat (map pprMatch (map unLoc (unLoc matches)))
-- Don't print the type; it's only a place-holder before typechecking
-pprMatches (XMatchGroup x) = ppr x
-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext
pprFunBind :: (OutputableBndrId idR, Outputable body)
@@ -1743,7 +1739,6 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
[] -> (empty, [])
[pat] -> (ppr pat, []) -- No parens around the single pat in a case
_ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
-pprMatch (XMatch nec) = noExtCon nec
pprGRHSs :: (OutputableBndrId idR, Outputable body)
=> HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc
@@ -1753,7 +1748,6 @@ pprGRHSs ctxt (GRHSs _ grhss (L _ binds))
-- EmptyLocalBinds means no "where" keyword
$$ ppUnless (eqEmptyLocalBinds binds)
(text "where" $$ nest 4 (pprBinds binds))
-pprGRHSs _ (XGRHSs x) = ppr x
pprGRHS :: (OutputableBndrId idR, Outputable body)
=> HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc
@@ -1763,8 +1757,6 @@ pprGRHS ctxt (GRHS _ [] body)
pprGRHS ctxt (GRHS _ guards body)
= sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]
-pprGRHS _ (XGRHS x) = ppr x
-
pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
@@ -1932,7 +1924,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
, recS_ret_fn :: SyntaxExpr idR -- The return function
, recS_mfix_fn :: SyntaxExpr idR -- The mfix function
}
- | XStmtLR (XXStmtLR idL idR body)
+ | XStmtLR !(XXStmtLR idL idR body)
-- Extra fields available post typechecking for RecStmt.
data RecStmtTc =
@@ -1997,7 +1989,7 @@ data ParStmtBlock idL idR
[ExprLStmt idL]
[IdP idR] -- The variables to be returned
(SyntaxExpr idR) -- The return operator
- | XParStmtBlock (XXParStmtBlock idL idR)
+ | XParStmtBlock !(XXParStmtBlock idL idR)
type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField
type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon
@@ -2027,7 +2019,7 @@ data ApplicativeArg idL
, final_expr :: (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn)
, bv_pattern :: (LPat idL) -- (v1,...,vn)
}
- | XApplicativeArg (XXApplicativeArg idL)
+ | XApplicativeArg !(XXApplicativeArg idL)
type instance XApplicativeArgOne (GhcPass _) = NoExtField
type instance XApplicativeArgMany (GhcPass _) = NoExtField
@@ -2264,7 +2256,6 @@ pprStmt (ApplicativeStmt _ args mb_join)
:: ExprStmt (GhcPass idL))]
flattenArg (_, ApplicativeArgMany _ stmts _ _) =
concatMap flattenStmt stmts
- flattenArg (_, XApplicativeArg nec) = noExtCon nec
pp_debug =
let
@@ -2276,8 +2267,6 @@ pprStmt (ApplicativeStmt _ args mb_join)
pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc
pp_arg (_, applicativeArg) = ppr applicativeArg
-pprStmt (XStmtLR x) = ppr x
-
instance (OutputableBndrId idL)
=> Outputable (ApplicativeArg (GhcPass idL)) where
@@ -2298,8 +2287,6 @@ pprArg (ApplicativeArgMany _ stmts return pat) =
(stmts ++
[noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)])))
-pprArg (XApplicativeArg x) = ppr x
-
pprTransformStmt :: (OutputableBndrId p)
=> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
-> Maybe (LHsExpr (GhcPass p)) -> SDoc
@@ -2392,7 +2379,7 @@ data HsSplice id
(XSpliced id)
ThModFinalizers -- TH finalizers produced by the splice.
(HsSplicedThing id) -- The result of splicing
- | XSplice (XXSplice id) -- Note [Trees that Grow] extension point
+ | XSplice !(XXSplice id) -- Note [Trees that Grow] extension point
newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data)
@@ -2576,8 +2563,10 @@ pprSplice (HsUntypedSplice _ BareSplice n e)
pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s
pprSplice (HsSpliced _ _ thing) = ppr thing
pprSplice (XSplice x) = case ghcPass @p of
+#if __GLASGOW_HASKELL__ < 811
GhcPs -> noExtCon x
GhcRn -> noExtCon x
+#endif
GhcTc -> case x of
HsSplicedT _ -> text "Unevaluated typed splice"
@@ -2601,7 +2590,7 @@ data HsBracket p
| VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T
-- (The Bool flag is used only in pprHsBracket)
| TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||]
- | XBracket (XXBracket p) -- Note [Trees that Grow] extension point
+ | XBracket !(XXBracket p) -- Note [Trees that Grow] extension point
type instance XExpBr (GhcPass _) = NoExtField
type instance XPatBr (GhcPass _) = NoExtField
@@ -2632,7 +2621,6 @@ pprHsBracket (VarBr _ True n)
pprHsBracket (VarBr _ False n)
= text "''" <> pprPrefixOcc n
pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e)
-pprHsBracket (XBracket e) = ppr e
thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 45753eaf47..b24bdf19b8 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -181,32 +181,27 @@ following:
type instance XXHsDecl (GhcPass _) = NoExtCon
data HsDecl p
= ...
- | XHsDecl (XXHsDecl p)
+ | XHsDecl !(XXHsDecl p)
-This means that any function that wishes to consume an HsDecl will need to
-have a case for XHsDecl. This might look like this:
+The field of type `XXHsDecl p` is strict for a good reason: it allows the
+pattern-match coverage checker to conclude that any matches against XHsDecl
+are unreachable whenever `p ~ GhcPass _`. To see why this is the case, consider
+the following function which consumes an HsDecl:
ex :: HsDecl GhcPs -> HsDecl GhcRn
...
ex (XHsDecl nec) = noExtCon nec
-Ideally, we wouldn't need a case for XHsDecl at all (it /is/ supposed to be
-an unused extension constructor, after all). There is a way to achieve this
-on GHC 8.8 or later: make the field of XHsDecl strict:
-
- data HsDecl p
- = ...
- | XHsDecl !(XXHsDecl p)
-
-If this is done, GHC's pattern-match coverage checker is clever enough to
-figure out that the XHsDecl case of `ex` is unreachable, so it can simply be
-omitted. (See Note [Extensions to GADTs Meet Their Match] in Check for more on
-how this works.)
+Because `p` equals GhcPs (i.e., GhcPass 'Parsed), XHsDecl's field has the type
+NoExtCon. But since (1) the field is strict and (2) NoExtCon is an empty data
+type, there is no possible way to reach the right-hand side of the XHsDecl
+case. As a result, the coverage checker concludes that the XHsDecl case is
+inaccessible, so it can be removed.
+(See Note [Strict argument type constraints] in GHC.HsToCore.PmCheck.Oracle for
+more on how this works.)
-When GHC drops support for bootstrapping with GHC 8.6 and earlier, we can make
-the strict field changes described above and delete gobs of code involving
-`noExtCon`. Until then, it is necessary to use, so be aware of it when writing
-code that consumes unused extension constructors.
+Bottom line: if you add a TTG extension constructor that uses NoExtCon, make
+sure that any uses of it as a field are strict.
-}
-- | Used as a data type index for the hsSyn AST; also serves
diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs
index aa85a98564..f0f62b9fb6 100644
--- a/compiler/GHC/Hs/ImpExp.hs
+++ b/compiler/GHC/Hs/ImpExp.hs
@@ -91,7 +91,7 @@ data ImportDecl pass
ideclHiding :: Maybe (Bool, Located [LIE pass])
-- ^ (True => hiding, names)
}
- | XImportDecl (XXImportDecl pass)
+ | XImportDecl !(XXImportDecl pass)
-- ^
-- 'ApiAnnotation.AnnKeywordId's
--
@@ -167,7 +167,6 @@ instance OutputableBndrId p
ppr_ies [] = text "()"
ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'
- ppr (XImportDecl x) = ppr x
{-
************************************************************************
@@ -253,7 +252,7 @@ data IE pass
| IEGroup (XIEGroup pass) Int HsDocString -- ^ Doc section heading
| IEDoc (XIEDoc pass) HsDocString -- ^ Some documentation
| IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc
- | XIE (XXIE pass)
+ | XIE !(XXIE pass)
type instance XIEVar (GhcPass _) = NoExtField
type instance XIEThingAbs (GhcPass _) = NoExtField
@@ -302,7 +301,6 @@ ieNames (IEModuleContents {}) = []
ieNames (IEGroup {}) = []
ieNames (IEDoc {}) = []
ieNames (IEDocNamed {}) = []
-ieNames (XIE nec) = noExtCon nec
ieWrappedName :: IEWrappedName name -> name
ieWrappedName (IEName (L _ n)) = n
@@ -344,7 +342,6 @@ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where
ppr (IEGroup _ n _) = text ("<IEGroup: " ++ show n ++ ">")
ppr (IEDoc _ doc) = ppr doc
ppr (IEDocNamed _ string) = text ("<IEDocNamed: " ++ string ++ ">")
- ppr (XIE x) = ppr x
instance (HasOccName name) => HasOccName (IEWrappedName name) where
occName w = occName (ieWrappedName w)
diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs
index 629ff6e32b..964df0d356 100644
--- a/compiler/GHC/Hs/Lit.hs
+++ b/compiler/GHC/Hs/Lit.hs
@@ -79,7 +79,7 @@ data HsLit x
| HsDoublePrim (XHsDoublePrim x) FractionalLit
-- ^ Unboxed Double
- | XLit (XXLit x)
+ | XLit !(XXLit x)
type instance XHsChar (GhcPass _) = SourceText
type instance XHsCharPrim (GhcPass _) = SourceText
@@ -120,7 +120,7 @@ data HsOverLit p
ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses]
| XOverLit
- (XXOverLit p)
+ !(XXOverLit p)
data OverLitTc
= OverLitTc {
@@ -150,7 +150,6 @@ negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"
overLitType :: HsOverLit GhcTc -> Type
overLitType (OverLit (OverLitTc _ ty) _ _) = ty
-overLitType (XOverLit nec) = noExtCon nec
-- | Convert a literal from one index type to another
convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)
@@ -167,7 +166,6 @@ convertLit (HsInteger a x b) = HsInteger a x b
convertLit (HsRat a x b) = HsRat a x b
convertLit (HsFloatPrim a x) = HsFloatPrim a x
convertLit (HsDoublePrim a x) = HsDoublePrim a x
-convertLit (XLit a) = XLit a
{-
Note [ol_rebindable]
@@ -244,7 +242,6 @@ instance Outputable (HsLit (GhcPass p)) where
ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w)
ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i)
ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)
- ppr (XLit x) = ppr x
pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc
pp_st_suffix NoSourceText _ doc = doc
@@ -255,7 +252,6 @@ instance OutputableBndrId p
=> Outputable (HsOverLit (GhcPass p)) where
ppr (OverLit {ol_val=val, ol_witness=witness})
= ppr val <+> (whenPprDebug (parens (pprExpr witness)))
- ppr (XOverLit x) = ppr x
instance Outputable OverLitVal where
ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i))
@@ -282,7 +278,6 @@ pmPprHsLit (HsInteger _ i _) = integer i
pmPprHsLit (HsRat _ f _) = ppr f
pmPprHsLit (HsFloatPrim _ f) = ppr f
pmPprHsLit (HsDoublePrim _ d) = ppr d
-pmPprHsLit (XLit x) = ppr x
-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs
-- to be parenthesized under precedence @p@.
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index fe5bbe65b6..bfa8bb9ed0 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -275,7 +275,7 @@ data Pat p
-- | Trees that Grow extension point for new constructors
| XPat
- (XXPat p)
+ !(XXPat p)
-- ---------------------------------------------------------------------
@@ -563,7 +563,6 @@ pprPat (ConPatOut { pat_con = con
<> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
, pprIfTc @p $ ppr binds ])
<+> pprConArgs details
-pprPat (XPat n) = noExtCon n
pprUserCon :: (OutputableBndr con, OutputableBndrId p)
@@ -737,8 +736,6 @@ isIrrefutableHsPat
-- since we cannot know until the splice is evaluated.
go (SplicePat {}) = False
- go (XPat nec) = noExtCon nec
-
-- | Is the pattern any of combination of:
--
-- - (pat)
diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs
index 6b2bd2dea2..d9a8ae3066 100644
--- a/compiler/GHC/Hs/Types.hs
+++ b/compiler/GHC/Hs/Types.hs
@@ -328,7 +328,7 @@ data LHsQTyVars pass -- See Note [HsType binders]
, hsq_explicit :: [LHsTyVarBndr pass]
-- Explicit variables, written by the user
}
- | XLHsQTyVars (XXLHsQTyVars pass)
+ | XLHsQTyVars !(XXLHsQTyVars pass)
type HsQTvsRn = [Name] -- Implicit variables
-- For example, in data T (a :: k1 -> k2) = ...
@@ -352,7 +352,6 @@ emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] }
isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool
isEmptyLHsQTvs (HsQTvs { hsq_ext = imp, hsq_explicit = exp })
= null imp && null exp
-isEmptyLHsQTvs _ = False
------------------------------------------------
-- HsImplicitBndrs
@@ -370,7 +369,7 @@ data HsImplicitBndrs pass thing -- See Note [HsType binders]
, hsib_body :: thing -- Main payload (type or list of types)
}
- | XHsImplicitBndrs (XXHsImplicitBndrs pass thing)
+ | XHsImplicitBndrs !(XXHsImplicitBndrs pass thing)
type instance XHsIB GhcPs _ = NoExtField
type instance XHsIB GhcRn _ = [Name]
@@ -392,7 +391,7 @@ data HsWildCardBndrs pass thing
-- If there is an extra-constraints wildcard,
-- it's still there in the hsc_body.
}
- | XHsWildCardBndrs (XXHsWildCardBndrs pass thing)
+ | XHsWildCardBndrs !(XXHsWildCardBndrs pass thing)
type instance XHsWC GhcPs b = NoExtField
type instance XHsWC GhcRn b = [Name]
@@ -413,7 +412,6 @@ type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both
hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing
hsImplicitBody (HsIB { hsib_body = body }) = body
-hsImplicitBody (XHsImplicitBndrs nec) = noExtCon nec
hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)
hsSigType = hsImplicitBody
@@ -500,7 +498,7 @@ data HsTyVarBndr pass
-- For details on above see note [Api annotations] in ApiAnnotation
| XTyVarBndr
- (XXTyVarBndr pass)
+ !(XXTyVarBndr pass)
type instance XUserTyVar (GhcPass _) = NoExtField
type instance XKindedTyVar (GhcPass _) = NoExtField
@@ -520,7 +518,6 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit
instance NamedThing (HsTyVarBndr GhcRn) where
getName (UserTyVar _ v) = unLoc v
getName (KindedTyVar _ v _) = unLoc v
- getName (XTyVarBndr nec) = noExtCon nec
-- | Haskell Type
data HsType pass
@@ -872,7 +869,7 @@ data ConDeclField pass -- Record fields have Haddock docs on them
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
-- For details on above see note [Api annotations] in ApiAnnotation
- | XConDeclField (XXConDeclField pass)
+ | XConDeclField !(XXConDeclField pass)
type instance XConDeclField (GhcPass _) = NoExtField
type instance XXConDeclField (GhcPass _) = NoExtCon
@@ -880,7 +877,6 @@ type instance XXConDeclField (GhcPass _) = NoExtCon
instance OutputableBndrId p
=> Outputable (ConDeclField (GhcPass p)) where
ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
- ppr (XConDeclField x) = ppr x
-- HsConDetails is used for patterns/expressions *and* for data type
-- declarations
@@ -944,8 +940,6 @@ hsWcScopedTvs sig_ty
, hst_bndrs = tvs }) ->
vars ++ nwcs ++ hsLTyVarNames tvs
_ -> nwcs
-hsWcScopedTvs (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec
-hsWcScopedTvs (XHsWildCardBndrs nec) = noExtCon nec
hsScopedTvs :: LHsSigType GhcRn -> [Name]
-- Same as hsWcScopedTvs, but for a LHsSigType
@@ -1023,7 +1017,6 @@ Bottom line: nip problems in the bud by matching on ForallInvis from the start.
hsTyVarName :: HsTyVarBndr (GhcPass p) -> IdP (GhcPass p)
hsTyVarName (UserTyVar _ (L _ n)) = n
hsTyVarName (KindedTyVar _ (L _ n) _) = n
-hsTyVarName (XTyVarBndr nec) = noExtCon nec
hsLTyVarName :: LHsTyVarBndr (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName = hsTyVarName . unLoc
@@ -1040,7 +1033,6 @@ hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]
hsAllLTyVarNames (HsQTvs { hsq_ext = kvs
, hsq_explicit = tvs })
= kvs ++ hsLTyVarNames tvs
-hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec
hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p))
hsLTyVarLocName = mapLoc hsTyVarName
@@ -1051,17 +1043,16 @@ hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Convert a LHsTyVarBndr to an equivalent LHsType.
hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)
hsLTyVarBndrToType = mapLoc cvt
- where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
+ where cvt :: HsTyVarBndr (GhcPass p) -> HsType (GhcPass p)
+ cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
cvt (KindedTyVar _ (L name_loc n) kind)
= HsKindSig noExtField
(L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind
- cvt (XTyVarBndr nec) = noExtCon nec
-- | Convert a LHsTyVarBndrs to a list of types.
-- Works on *type* variable only, no kind vars.
hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)]
hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs
-hsLTyVarBndrsToTypes (XLHsQTyVars nec) = noExtCon nec
-- | Get the kind signature of a type, ignoring parentheses:
--
@@ -1282,7 +1273,6 @@ splitLHsInstDeclTy (HsIB { hsib_ext = itkvs
= (itkvs ++ hsLTyVarNames tvs, cxt, body_ty)
-- Return implicitly bound type and kind vars
-- For an instance decl, all of them are in scope
-splitLHsInstDeclTy (XHsImplicitBndrs nec) = noExtCon nec
getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)
getLHsInstDeclHead inst_ty
@@ -1319,7 +1309,7 @@ data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass
}
| XFieldOcc
- (XXFieldOcc pass)
+ !(XXFieldOcc pass)
deriving instance Eq (XCFieldOcc (GhcPass p)) => Eq (FieldOcc (GhcPass p))
type instance XCFieldOcc GhcPs = NoExtField
@@ -1350,7 +1340,7 @@ mkFieldOcc rdr = FieldOcc noExtField rdr
data AmbiguousFieldOcc pass
= Unambiguous (XUnambiguous pass) (Located RdrName)
| Ambiguous (XAmbiguous pass) (Located RdrName)
- | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass)
+ | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass)
type instance XUnambiguous GhcPs = NoExtField
type instance XUnambiguous GhcRn = Name
@@ -1375,23 +1365,17 @@ mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr
rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName
rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr
rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr
-rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc nec)
- = noExtCon nec
selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id
selectorAmbiguousFieldOcc (Unambiguous sel _) = sel
selectorAmbiguousFieldOcc (Ambiguous sel _) = sel
-selectorAmbiguousFieldOcc (XAmbiguousFieldOcc nec)
- = noExtCon nec
unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc
unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel
-unambiguousFieldOcc (XAmbiguousFieldOcc nec) = noExtCon nec
ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc
ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr
-ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec
{-
************************************************************************
@@ -1410,23 +1394,19 @@ instance Outputable HsTyLit where
instance OutputableBndrId p
=> Outputable (LHsQTyVars (GhcPass p)) where
ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs
- ppr (XLHsQTyVars x) = ppr x
instance OutputableBndrId p
=> Outputable (HsTyVarBndr (GhcPass p)) where
ppr (UserTyVar _ n) = ppr n
ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k]
- ppr (XTyVarBndr nec) = noExtCon nec
instance Outputable thing
=> Outputable (HsImplicitBndrs (GhcPass p) thing) where
ppr (HsIB { hsib_body = ty }) = ppr ty
- ppr (XHsImplicitBndrs x) = ppr x
instance Outputable thing
=> Outputable (HsWildCardBndrs (GhcPass p) thing) where
ppr (HsWC { hswc_body = ty }) = ppr ty
- ppr (XHsWildCardBndrs x) = ppr x
pprAnonWildCard :: SDoc
pprAnonWildCard = char '_'
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 7c59c8abdb..99a5de9365 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -979,7 +979,6 @@ collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds
-- No pattern synonyms here
collectLocalBinders (HsIPBinds {}) = []
collectLocalBinders (EmptyLocalBinds _) = []
-collectLocalBinders (XHsLocalBindsLR _) = []
collectHsIdBinders, collectHsValBinders
:: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
@@ -1067,8 +1066,6 @@ collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
where
collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
- collectArgBinders _ = []
-collectStmtBinders (XStmtLR nec) = noExtCon nec
----------------- Patterns --------------------------
@@ -1144,7 +1141,6 @@ hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_fords = foreign_decls })
= collectHsValBinders val_decls
++ hsTyClForeignBinders tycl_decls foreign_decls
-hsGroupBinders (XHsGroup nec) = noExtCon nec
hsTyClForeignBinders :: [TyClGroup GhcRn]
-> [LForeignDecl GhcRn]
@@ -1176,8 +1172,6 @@ hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p))
hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl
{ fdLName = (L _ name) } }))
= ([L loc name], [])
-hsLTyClDeclBinders (L _ (FamDecl { tcdFam = XFamilyDecl nec }))
- = noExtCon nec
hsLTyClDeclBinders (L loc (SynDecl
{ tcdLName = (L _ name) }))
= ([L loc name], [])
@@ -1195,7 +1189,6 @@ hsLTyClDeclBinders (L loc (ClassDecl
hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name)
, tcdDataDefn = defn }))
= (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
-hsLTyClDeclBinders (L _ (XTyClDecl nec)) = noExtCon nec
-------------------
@@ -1236,10 +1229,6 @@ hsLInstDeclBinders (L _ (ClsInstD
hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
= hsDataFamInstBinders fi
hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
-hsLInstDeclBinders (L _ (ClsInstD _ (XClsInstDecl nec)))
- = noExtCon nec
-hsLInstDeclBinders (L _ (XInstDecl nec))
- = noExtCon nec
-------------------
-- | the 'SrcLoc' returned are for the whole declarations, not just the names
@@ -1249,11 +1238,6 @@ hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = defn }}})
= hsDataDefnBinders defn
-- There can't be repeated symbols because only data instances have binders
-hsDataFamInstBinders (DataFamInstDecl
- { dfid_eqn = HsIB { hsib_body = XFamEqn nec}})
- = noExtCon nec
-hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs nec))
- = noExtCon nec
-------------------
-- | the 'SrcLoc' returned are for the whole declarations, not just the names
@@ -1262,7 +1246,6 @@ hsDataDefnBinders :: HsDataDefn (GhcPass p)
hsDataDefnBinders (HsDataDefn { dd_cons = cons })
= hsConDeclsBinders cons
-- See Note [Binders in family instances]
-hsDataDefnBinders (XHsDataDefn nec) = noExtCon nec
-------------------
type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)]
@@ -1298,8 +1281,6 @@ hsConDeclsBinders cons
(remSeen', flds) = get_flds remSeen args
(ns, fs) = go remSeen' rs
- XConDecl nec -> noExtCon nec
-
get_flds :: Seen p -> HsConDeclDetails (GhcPass p)
-> (Seen p, [LFieldOcc (GhcPass p)])
get_flds remSeen (RecCon flds)
@@ -1367,7 +1348,6 @@ lStmtsImplicits = hs_lstmts
hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts
- do_arg (_, XApplicativeArg nec) = noExtCon nec
hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds)
hs_stmt (BodyStmt {}) = []
hs_stmt (LastStmt {}) = []
@@ -1375,12 +1355,10 @@ lStmtsImplicits = hs_lstmts
, s <- ss]
hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
- hs_stmt (XStmtLR nec) = noExtCon nec
hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
hs_local_binds (HsIPBinds {}) = []
hs_local_binds (EmptyLocalBinds _) = []
- hs_local_binds (XHsLocalBindsLR _) = []
hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]
hsValBindsImplicits (XValBindsLR (NValBinds binds _))
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index c89efc10b7..1afb0e2ff6 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -417,7 +417,6 @@ dsRule (L loc (HsRule { rd_name = name
; return (Just rule)
} } }
-dsRule (L _ (XRuleDecl nec)) = noExtCon nec
warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
-- See Note [Rules and inlining/other rules]
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index 479e804ecf..0371d37e31 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -333,7 +333,6 @@ dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
(Lam var match_code)
core_cmd
return (mkLets meth_binds proc_code)
-dsProcExpr _ _ = panic "dsProcExpr"
{-
Translation of a command judgement of the form
@@ -721,7 +720,6 @@ dsTrimCmdArg local_vars env_ids
arg_code = if env_ids' == env_ids then core_cmd else
do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
return (mkLets meth_binds arg_code, free_vars)
-dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg"
-- Given D; xs |-a c : stk --> t, builds c with xs fed back.
-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
@@ -1151,7 +1149,6 @@ leavesMatch (L _ (Match { m_pats = pats
mkVarSet (collectLStmtsBinders stmts)
`unionVarSet` defined_vars)
| L _ (GRHS _ stmts body) <- grhss]
-leavesMatch _ = panic "leavesMatch"
-- Replace the leaf commands in a match
@@ -1168,7 +1165,6 @@ replaceLeavesMatch _res_ty leaves
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
(leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds }))
-replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch"
replaceLeavesGRHS
:: [Located (body' GhcTc)] -- replacement leaf expressions of that type
@@ -1178,7 +1174,6 @@ replaceLeavesGRHS
replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))
= (leaves, L loc (GRHS x stmts leaf))
replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
-replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS"
-- Balanced fold of a non-empty list.
@@ -1248,7 +1243,6 @@ collectl (L _ pat) bndrs
go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ _ pat) = collectl pat bndrs
go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
- go (XPat nec) = noExtCon nec
collectEvBinders :: TcEvBinds -> [Id]
collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index e5e7838834..cdd73c9171 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -205,7 +205,6 @@ dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
-dsHsBind _ (XHsBindsLR nec) = noExtCon nec
-----------------------
@@ -265,7 +264,6 @@ dsAbsBinds dflags tyvars dicts exports
; return (makeCorePair dflags global
(isDefaultMethod prags)
0 (core_wrap (Var local))) }
- mk_bind (XABExport nec) = noExtCon nec
; main_binds <- mapM mk_bind exports
; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
@@ -310,7 +308,6 @@ dsAbsBinds dflags tyvars dicts exports
-- the user written (local) function. The global
-- Id is just the selector. Hmm.
; return ((global', rhs) : fromOL spec_binds) }
- mk_bind (XABExport nec) = noExtCon nec
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index ba15a8b8e6..3b6da2c5bb 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -304,10 +304,6 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
addPathEntry name $
addTickMatchGroup False (fun_matches funBind)
- case mg of
- MG {} -> return ()
- _ -> panic "addTickLHsBind"
-
blackListed <- isBlackListed pos
exported_names <- liftM exports getEnv
@@ -378,7 +374,6 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
-- Only internal stuff, not from source, uses VarBind, so we ignore it.
addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
-addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
bindTick
:: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
@@ -647,7 +642,6 @@ addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e
; return (L l (Present x e')) }
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
-addTickTupArg (L _ (XTupArg nec)) = noExtCon nec
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
@@ -656,7 +650,6 @@ addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ mg { mg_alts = L l matches' }
-addTickMatchGroup _ (XMatchGroup nec) = noExtCon nec
addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
-> TM (Match GhcTc (LHsExpr GhcTc))
@@ -665,7 +658,6 @@ addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
return $ match { m_grhss = gRHSs' }
-addTickMatch _ _ (XMatch nec) = noExtCon nec
addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-> TM (GRHSs GhcTc (LHsExpr GhcTc))
@@ -676,7 +668,6 @@ addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do
return $ GRHSs x guarded' (L l local_binds')
where
binders = collectLocalBinders local_binds
-addTickGRHSs _ _ (XGRHSs nec) = noExtCon nec
addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
-> TM (GRHS GhcTc (LHsExpr GhcTc))
@@ -684,7 +675,6 @@ addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
(stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
(addTickGRHSBody isOneOfMany isLambda expr)
return $ GRHS x stmts' expr'
-addTickGRHS _ _ (XGRHS nec) = noExtCon nec
addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
@@ -763,8 +753,6 @@ addTickStmt isGuard stmt@(RecStmt {})
; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-addTickStmt _ (XStmtLR nec) = noExtCon nec
-
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
@@ -786,7 +774,6 @@ addTickApplicativeArg isGuard (op, arg) =
<$> addTickLStmts isGuard stmts
<*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
<*> addTickLPat pat
- addTickArg (XApplicativeArg nec) = noExtCon nec
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-> TM (ParStmtBlock GhcTc GhcTc)
@@ -795,7 +782,6 @@ addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
(addTickLStmts isGuard stmts)
(return ids)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
-addTickStmtAndBinders _ (XParStmtBlock nec) = noExtCon nec
addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
addTickHsLocalBinds (HsValBinds x binds) =
@@ -805,7 +791,6 @@ addTickHsLocalBinds (HsIPBinds x binds) =
liftM (HsIPBinds x)
(addTickHsIPBinds binds)
addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x)
-addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x)
addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
-> TM (HsValBindsLR GhcTc (GhcPass b))
@@ -825,14 +810,12 @@ addTickHsIPBinds (IPBinds dictbinds ipbinds) =
liftM2 IPBinds
(return dictbinds)
(mapM (liftL (addTickIPBind)) ipbinds)
-addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
addTickIPBind (IPBind x nm e) =
liftM2 (IPBind x)
(return nm)
(addTickLHsExpr e)
-addTickIPBind (XIPBind x) = return (XIPBind x)
-- There is no location here, so we might need to use a context location??
addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
@@ -850,7 +833,6 @@ addTickHsCmdTop (HsCmdTop x cmd) =
liftM2 HsCmdTop
(return x)
(addTickLHsCmd cmd)
-addTickHsCmdTop (XCmdTop nec) = noExtCon nec
addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc)
addTickLHsCmd (L pos c0) = do
@@ -915,14 +897,12 @@ addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
matches' <- mapM (liftL addTickCmdMatch) matches
return $ mg { mg_alts = L l matches' }
-addTickCmdMatchGroup (XMatchGroup nec) = noExtCon nec
addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
bindLocals (collectPatsBinders pats) $ do
gRHSs' <- addTickCmdGRHSs gRHSs
return $ match { m_grhss = gRHSs' }
-addTickCmdMatch (XMatch nec) = noExtCon nec
addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do
@@ -932,7 +912,6 @@ addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do
return $ GRHSs x guarded' (L l local_binds')
where
binders = collectLocalBinders local_binds
-addTickCmdGRHSs (XGRHSs nec) = noExtCon nec
addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
-- The *guards* are *not* Cmds, although the body is
@@ -941,7 +920,6 @@ addTickCmdGRHS (GRHS x stmts cmd)
= do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
stmts (addTickLHsCmd cmd)
; return $ GRHS x stmts' expr' }
-addTickCmdGRHS (XGRHS nec) = noExtCon nec
addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
-> TM [LStmt GhcTc (LHsCmd GhcTc)]
@@ -988,8 +966,6 @@ addTickCmdStmt stmt@(RecStmt {})
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
addTickCmdStmt ApplicativeStmt{} =
panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
-addTickCmdStmt (XStmtLR nec) =
- noExtCon nec
-- Others should never happen in a command context.
addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)
@@ -1296,11 +1272,9 @@ hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
matchesOneOfMany :: [LMatch GhcTc body] -> Bool
matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
where
+ matchCount :: LMatch GhcTc body -> Int
matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))
= length grhss
- matchCount (L _ (Match { m_grhss = XGRHSs nec }))
- = noExtCon nec
- matchCount (L _ (XMatch nec)) = noExtCon nec
type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index 967e4c3185..48a8ef6f20 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -151,12 +151,6 @@ getInstLoc = \case
-- equation. This does not happen for data family instances, for some
-- reason.
{ tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = L l _ }}}) -> l
- ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
- DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
- TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
- XInstDecl _ -> error "getInstLoc"
- DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
- TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
-- | Get all subordinate declarations inside a declaration, and their docs.
-- A subordinate declaration is something like the associate type or data
@@ -292,9 +286,11 @@ ungroup group_ =
mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++
mkDecls (valbinds . hs_valds) (ValD noExtField) group_
where
+ typesigs :: HsValBinds GhcRn -> [LSig GhcRn]
typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
typesigs ValBinds{} = error "expected XValBindsLR"
+ valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn]
valbinds (XValBindsLR (NValBinds binds _)) =
concatMap bagToList . snd . unzip $ binds
valbinds ValBinds{} = error "expected XValBindsLR"
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 8b518cb988..a1727659af 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -84,7 +84,6 @@ dsLocalBinds (L _ (EmptyLocalBinds _)) body = return body
dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
dsValBinds binds body
dsLocalBinds (L _ (HsIPBinds _ binds)) body = dsIPBinds binds body
-dsLocalBinds _ _ = panic "dsLocalBinds"
-------------------------
-- caller sets location
@@ -105,8 +104,6 @@ dsIPBinds (IPBinds ev_binds ip_binds) body
ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
= do e' <- dsLExpr e
return (Let (NonRec n e') body)
- ds_ip_bind _ _ = panic "dsIPBinds"
-dsIPBinds (XHsIPBinds nec) _ = noExtCon nec
-------------------------
-- caller sets location
@@ -396,7 +393,6 @@ dsExpr (ExplicitTuple _ tup_args boxity)
-- lambdas, just arguments.
= do { core_expr <- dsLExprNoLP expr
; return (lam_vars, core_expr : args) }
- go _ _ = panic "dsExpr"
; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
-- The reverse is because foldM goes left-to-right
@@ -786,7 +782,6 @@ ds_prag_expr (HsPragTick _ _ _ _) expr = do
if gopt Opt_Hpc dflags
then panic "dsExpr:HsPragTick"
else dsLExpr expr
-ds_prag_expr (XHsPragE x) _ = noExtCon x
------------------------------
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
@@ -960,7 +955,6 @@ dsDo stmts
((pat, fail_op), dsLExpr expr)
do_arg (ApplicativeArgMany _ stmts ret pat) =
((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
- do_arg (XApplicativeArg nec) = noExtCon nec
; rhss' <- sequence rhss
@@ -1018,7 +1012,6 @@ dsDo stmts
go _ (ParStmt {}) _ = panic "dsDo ParStmt"
go _ (TransStmt {}) _ = panic "dsDo TransStmt"
- go _ (XStmtLR nec) _ = noExtCon nec
dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index 49cfe5779a..f30e1bab1d 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -100,6 +100,7 @@ dsForeigns' fos = do
where
do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)
+ do_decl :: ForeignDecl GhcTc -> DsM (SDoc, SDoc, [Id], [Binding])
do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
traceIf (text "fi start" <+> ppr id)
let id' = unLoc id
@@ -113,7 +114,6 @@ dsForeigns' fos = do
(L _ (CExportStatic _ ext_nm cconv)) _ }) = do
(h, c, _, _) <- dsFExport id co ext_nm cconv False
return (h, c, [id], [])
- do_decl (XForeignDecl nec) = noExtCon nec
{-
************************************************************************
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
index 6a8bc53313..5763fac71b 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ b/compiler/GHC/HsToCore/GuardedRHSs.hs
@@ -71,13 +71,11 @@ dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty mb_rhss_deltas
match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
-- NB: nested dsLet inside matchResult
; return match_result2 }
-dsGRHSs _ (XGRHSs nec) _ _ = noExtCon nec
dsGRHS :: HsMatchContext GhcRn -> Type -> Deltas -> LGRHS GhcTc (LHsExpr GhcTc)
-> DsM MatchResult
dsGRHS hs_ctx rhs_ty rhs_deltas (L _ (GRHS _ guards rhs))
= updPmDeltas rhs_deltas (matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty)
-dsGRHS _ _ _ (L _ (XGRHS nec)) = noExtCon nec
{-
************************************************************************
@@ -140,8 +138,6 @@ matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"
matchGuards (ApplicativeStmt {} : _) _ _ _ =
panic "matchGuards ApplicativeLastStmt"
-matchGuards (XStmtLR nec : _) _ _ _ =
- noExtCon nec
{-
Should {\em fail} if @e@ returns @D@
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 8c27321824..3341427ef0 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -91,7 +91,6 @@ dsInnerListComp (ParStmtBlock _ stmts bndrs _)
; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
; return (expr, bndrs_tuple_type) }
-dsInnerListComp (XParStmtBlock nec) = noExtCon nec
-- This function factors out commonality between the desugaring strategies for GroupStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
@@ -267,9 +266,6 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
deListComp (ApplicativeStmt {} : _) _ =
panic "deListComp ApplicativeStmt"
-deListComp (XStmtLR nec : _) _ =
- noExtCon nec
-
deBindComp :: OutPat GhcTc
-> CoreExpr
-> [ExprStmt GhcTc]
@@ -364,8 +360,6 @@ dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
dfListComp _ _ (ApplicativeStmt {} : _) =
panic "dfListComp ApplicativeStmt"
-dfListComp _ _ (XStmtLR nec : _) =
- noExtCon nec
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat GhcTc, CoreExpr)
@@ -593,10 +587,10 @@ dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
where
+ ds_inner :: ParStmtBlock GhcTc GhcTc -> DsM (CoreExpr, Type)
ds_inner (ParStmtBlock _ stmts bndrs return_op)
= do { exp <- dsInnerMonadComp stmts bndrs return_op
; return (exp, mkBigCoreVarTupTy bndrs) }
- ds_inner (XParStmtBlock nec) = noExtCon nec
dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 54d90ee284..c479586b76 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -770,7 +770,6 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
mk_eqn_infos [] _ = return []
-- Called once per equation in the match, or alternative in the case
mk_eqn_info (Match { m_pats = pats, m_grhss = grhss }) rhss_deltas
- | XGRHSs nec <- grhss = noExtCon nec
| GRHSs _ grhss' _ <- grhss, let n_grhss = length grhss'
= do { dflags <- getDynFlags
; let upats = map (unLoc . decideBangHood dflags) pats
@@ -786,12 +785,10 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
, eqn_orig = FromSource
, eqn_rhs = match_result }
, rhss_deltas' ) }
- mk_eqn_info (XMatch nec) _ = noExtCon nec
handleWarnings = if isGenerated origin
then discardWarningsDs
else id
-matchWrapper _ _ (XMatchGroup nec) = noExtCon nec
matchEquations :: HsMatchContext GhcRn
-> [MatchId] -> [EquationInfo] -> Type
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index 3afc455e99..17bf1484b2 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -103,7 +103,6 @@ dsLit l = do
HsString _ str -> mkStringExprFS str
HsInteger _ i _ -> mkIntegerExpr i
HsInt _ i -> return (mkIntExpr platform (il_value i))
- XLit nec -> noExtCon nec
HsRat _ (FL _ _ val) ty -> do
num <- mkIntegerExpr (numerator val)
denom <- mkIntegerExpr (denominator val)
@@ -125,7 +124,6 @@ dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
case shortCutLit platform val ty of
Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut]
_ -> dsExpr witness
-dsOverLit (XOverLit nec) = noExtCon nec
{-
Note [Literal short cut]
~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs
index 37fef0fc03..b22ef27d85 100644
--- a/compiler/GHC/HsToCore/PmCheck.hs
+++ b/compiler/GHC/HsToCore/PmCheck.hs
@@ -286,7 +286,6 @@ checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
, m_pats = []
, m_grhss = guards }
checkMatches dsMatchContext [] [match]
-checkGuardMatches _ (XGRHSs nec) = noExtCon nec
-- | Check a list of syntactic /match/es (part of case, functions, etc.), each
-- with a /pat/ and one or more /grhss/:
@@ -547,7 +546,6 @@ translatePat fam_insts x pat = case pat of
-- Not supposed to happen
ConPatIn {} -> panic "Check.translatePat: ConPatIn"
SplicePat {} -> panic "Check.translatePat: SplicePat"
- XPat n -> noExtCon n
-- | 'translatePat', but also select and return a new match var.
translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec)
@@ -642,7 +640,6 @@ translateMatch fam_insts vars (L match_loc (Match { m_pats = pats, m_grhss = grh
grhss' <- mapM (translateLGRHS fam_insts match_loc pats) (grhssGRHSs grhss)
-- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr grhss, ppr grhss'])
return (mkGrdTreeMany pats' grhss')
-translateMatch _ _ (L _ (XMatch nec)) = noExtCon nec
-- -----------------------------------------------------------------------
-- * Transform source guards (GuardStmt Id) to simpler PmGrds
@@ -657,7 +654,6 @@ translateLGRHS fam_insts match_loc pats (L _loc (GRHS _ gs _)) =
| null gs = L match_loc (sep (map ppr pats))
| otherwise = L grd_loc (sep (map ppr pats) <+> vbar <+> interpp'SP gs)
L grd_loc _ = head gs
-translateLGRHS _ _ _ (L _ (XGRHS nec)) = noExtCon nec
-- | Translate a guard statement to a 'GrdVec'
translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM GrdVec
@@ -670,7 +666,6 @@ translateGuard fam_insts guard = case guard of
TransStmt {} -> panic "translateGuard TransStmt"
RecStmt {} -> panic "translateGuard RecStmt"
ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"
- XStmtLR nec -> noExtCon nec
-- | Translate let-bindings
translateLet :: HsLocalBinds GhcTc -> DsM GrdVec
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index d73b288d07..d047170feb 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -169,7 +169,6 @@ dsBracket wrap brack splices
do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL"
do_brack (TExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 }
- do_brack (XBracket nec) = noExtCon nec
{-
Note [Desugaring Brackets]
@@ -317,13 +316,12 @@ repTopDs group@(HsGroup { hs_valds = valds
= notHandledL loc "Splices within declaration brackets" empty
no_default_decl (L loc decl)
= notHandledL loc "Default declarations" (ppr decl)
+ no_warn :: LWarnDecl GhcRn -> MetaM a
no_warn (L loc (Warning _ thing _))
= notHandledL loc "WARNING and DEPRECATION pragmas" $
text "Pragma for declaration of" <+> ppr thing
- no_warn (L _ (XWarnDecl nec)) = noExtCon nec
no_doc (L loc _)
= notHandledL loc "Haddock documentation" empty
-repTopDs (XHsGroup nec) = noExtCon nec
hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
-- See Note [Scoped type variables in bindings]
@@ -345,6 +343,7 @@ get_scoped_tvs (L _ signature)
| otherwise
= []
where
+ get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]
get_scoped_tvs_from_sig sig
-- Both implicit and explicit quantified variables
-- We need the implicit ones for f :: forall (a::k). blah
@@ -353,8 +352,6 @@ get_scoped_tvs (L _ signature)
, hsib_body = hs_ty } <- sig
, (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty
= implicit_vars ++ hsLTyVarNames explicit_vars
- get_scoped_tvs_from_sig (XHsImplicitBndrs nec)
- = noExtCon nec
{- Notes
@@ -480,8 +477,6 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
; return $ Just (loc, dec)
}
-repTyClD (L _ (XTyClDecl nec)) = noExtCon nec
-
-------------------------
repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRoleD (L loc (RoleAnnotDecl _ tycon roles))
@@ -490,14 +485,12 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles))
; roles2 <- coreList roleTyConName roles1
; dec <- repRoleAnnotD tycon1 roles2
; return (loc, dec) }
-repRoleD (L _ (XRoleAnnotDecl nec)) = noExtCon nec
-------------------------
repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repKiSigD (L loc kisig) =
case kisig of
StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
- XStandaloneKindSig nec -> noExtCon nec
-------------------------
repDataDefn :: Core TH.Name
@@ -526,7 +519,6 @@ repDataDefn tc opts
; repData cxt1 tc opts ksig' cons1
derivs1 }
}
-repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec
repSynDecl :: Core TH.Name -> Core [(M TH.TyVarBndr)]
-> LHsType GhcRn
@@ -568,7 +560,6 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info
; repDataFamilyD tc1 bndrs kind }
; return (loc, dec)
}
-repFamilyDecl (L _ (XFamilyDecl nec)) = noExtCon nec
-- | Represent result signature of a type family
repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig))
@@ -577,7 +568,6 @@ repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki
; repKindSig ki' }
repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
; repTyVarSig bndr' }
-repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec
-- | Represent result signature using a Maybe Kind. Used with data families,
-- where the result signature can be either missing or a kind but never a named
@@ -590,7 +580,6 @@ repFamilyResultSigToMaybeKind (KindSig _ ki) =
do { coreJustM kindTyConName =<< repLTy ki }
repFamilyResultSigToMaybeKind TyVarSig{} =
panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"
-repFamilyResultSigToMaybeKind (XFamilyResultSig nec) = noExtCon nec
-- | Represent injectivity annotation of a type family
repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
@@ -634,7 +623,6 @@ repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
= do { dec <- repClsInstD cls_decl
; return (loc, dec) }
-repInstD (L _ (XInstDecl nec)) = noExtCon nec
repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
@@ -664,7 +652,6 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
; wrapGenSyms ss decls2 }
where
(tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
-repClsInstD (XClsInstDecl nec) = noExtCon nec
repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
@@ -677,7 +664,6 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
; return (loc, dec) }
where
(tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
-repStandaloneDerivD (L _ (XDerivDecl nec)) = noExtCon nec
repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
@@ -709,8 +695,6 @@ repTyFamEqn (HsIB { hsib_ext = var_names
where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
checkTys tys@(HsValArg _:HsValArg _:_) = return tys
checkTys _ = panic "repTyFamEqn:checkTys"
-repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec
-repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec
repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))
repTyArgs f [] = f
@@ -749,11 +733,6 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn =
checkTys tys@(HsValArg _: HsValArg _: _) = return tys
checkTys _ = panic "repDataFamInstD:checkTys"
-repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))
- = noExtCon nec
-repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))
- = noExtCon nec
-
repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec))
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
, fd_fi = CImport (L _ cc)
@@ -784,7 +763,6 @@ repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
_ -> ""
repForD decl@(L _ ForeignExport{}) = notHandled "Foreign export" (ppr decl)
-repForD (L _ (XForeignDecl nec)) = noExtCon nec
repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)
repCCallConv CCallConv = rep2_nw cCallName []
@@ -813,7 +791,6 @@ rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
; dec <- rep2 rep_fn [prec', name']
; return (loc,dec) }
; mapM do_one names }
-rep_fix_d _ (XFixitySig nec) = noExtCon nec
repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repRuleD (L loc (HsRule { rd_name = n
@@ -840,18 +817,12 @@ repRuleD (L loc (HsRule { rd_name = n
; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
; wrapGenSyms ss rule }
; return (loc, rule) }
-repRuleD (L _ (XRuleDecl nec)) = noExtCon nec
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig _ n sig))
| HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
= unLoc n : vars
-ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs nec))))
- = noExtCon nec
-ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs nec)))
- = noExtCon nec
-ruleBndrNames (L _ (XRuleBndr nec)) = noExtCon nec
repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))
repRuleBndr (L _ (RuleBndr _ n))
@@ -861,7 +832,6 @@ repRuleBndr (L _ (RuleBndrSig _ n sig))
= do { MkC n' <- lookupLBinder n
; MkC ty' <- repLTy (hsSigWcType sig)
; rep2 typedRuleVarName [n', ty'] }
-repRuleBndr (L _ (XRuleBndr nec)) = noExtCon nec
repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
@@ -869,7 +839,6 @@ repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
; exp' <- repE exp
; dec <- repPragAnn target exp'
; return (loc, dec) }
-repAnnD (L _ (XAnnDecl nec)) = noExtCon nec
repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget)
repAnnProv (ValueAnnProvenance (L _ n))
@@ -925,8 +894,6 @@ repC (L _ (ConDeclGADT { con_names = cons
then return c'
else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
-repC (L _ (XConDecl nec)) = noExtCon nec
-
repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
repMbContext Nothing = repContext []
@@ -973,7 +940,6 @@ repDerivClause (L _ (HsDerivingClause
where
rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type))
rep_deriv_ty ty = repLTy ty
-repDerivClause (L _ (XHsDerivingClause nec)) = noExtCon nec
rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
-> MetaM ([GenSymBind], [Core (M TH.Dec)])
@@ -1017,7 +983,6 @@ rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
rep_sig (L loc (CompleteMatchSig _ _st cls mty))
= rep_complete_sig cls mty loc
-rep_sig (L _ (XSig nec)) = noExtCon nec
rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
-> MetaM (SrcSpan, Core (M TH.Dec))
@@ -1043,7 +1008,6 @@ rep_ty_sig mk_sig loc sig_ty nm
else repTForall th_explicit_tvs th_ctxt th_ty
; sig <- repProto mk_sig nm1 ty1
; return (loc, sig) }
-rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec
rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
-> MetaM (SrcSpan, Core (M TH.Dec))
@@ -1072,7 +1036,6 @@ rep_patsyn_ty_sig loc sig_ty nm
repTForall th_exis th_provs th_ty
; sig <- repProto patSynSigDName nm1 ty1
; return (loc, sig) }
-rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec
rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
-> MetaM (SrcSpan, Core (M TH.Dec))
@@ -1180,7 +1143,6 @@ addTyVarBinds (HsQTvs { hsq_ext = imp_tvs
= addSimpleTyVarBinds imp_tvs $
addHsTyVarBinds exp_tvs $
thing_inside
-addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec
addTyClTyVarBinds :: LHsQTyVars GhcRn
-> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a)))
@@ -1217,7 +1179,6 @@ repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
= repPlainTV nm
repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
= repLTy ki >>= repKindedTV nm
-repTyVarBndrWithKind (L _ (XTyVarBndr nec)) _ = noExtCon nec
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr))
@@ -1228,7 +1189,6 @@ repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki))
= do { nm' <- lookupBinder nm
; ki' <- repLTy ki
; repKindedTV nm' ki' }
-repTyVarBndr (L _ (XTyVarBndr nec)) = noExtCon nec
-- represent a type context
--
@@ -1251,12 +1211,10 @@ repHsSigType (HsIB { hsib_ext = implicit_tvs
; if null explicit_tvs && null (unLoc ctxt)
then return th_ty
else repTForall th_explicit_tvs th_ctxt th_ty }
-repHsSigType (XHsImplicitBndrs nec) = noExtCon nec
repHsSigWcType :: LHsSigWcType GhcRn -> MetaM (Core (M TH.Type))
repHsSigWcType (HsWC { hswc_body = sig1 })
= repHsSigType sig1
-repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec
-- yield the representation of a list of types
repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]
@@ -1389,7 +1347,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 (XSplice nec) = noExtCon nec
rep_splice :: Name -> MetaM (Core a)
rep_splice splice_name
@@ -1428,7 +1385,6 @@ repE (HsOverLabel _ _ s) = repOverLabel s
repE e@(HsRecFld _ f) = case f of
Unambiguous x _ -> repE (HsVar noExtField (noLoc x))
Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
- XAmbiguousFieldOcc nec -> noExtCon nec
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
@@ -1556,7 +1512,6 @@ repE (HsUnboundVar _ uv) = do
repE e@(HsPragE _ HsPragCore {} _) = notHandled "Core annotations" (ppr e)
repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e)
repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e)
-repE (XExpr nec) = noExtCon nec
repE e = notHandled "Expression form" (ppr e)
-----------------------------------------------------------------------------
@@ -1586,8 +1541,6 @@ repClauseTup (L _ (Match { m_pats = ps
gs <- repGuards guards
; clause <- repClause ps1 gs ds
; wrapGenSyms (ss1++ss2) clause }}}
-repClauseTup (L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec
-repClauseTup (L _ (XMatch nec)) = noExtCon nec
repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> MetaM (Core (M TH.Body))
repGuards [L _ (GRHS _ [] e)]
@@ -1608,7 +1561,6 @@ repLGRHS (L _ (GRHS _ ss rhs))
; rhs' <- addBinds gs $ repLE rhs
; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
; return (gs, guarded) }
-repLGRHS (L _ (XGRHS nec)) = noExtCon nec
repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp])
repFields (HsRecFields { rec_flds = flds })
@@ -1629,7 +1581,6 @@ repUpdFields = repListM fieldExpTyConName rep_fld
; e <- repLE (hsRecFieldArg fld)
; repFieldExp fn e }
Ambiguous{} -> notHandled "Ambiguous record updates" (ppr fld)
- XAmbiguousFieldOcc nec -> noExtCon nec
@@ -1694,7 +1645,6 @@ repSts (ParStmt _ stmt_blocks _ _ : ss) =
do { (ss1, zs) <- repSts (map unLoc stmts)
; zs1 <- coreListM stmtTyConName zs
; return (ss1, zs1) }
- rep_stmt_block (XParStmtBlock nec) = noExtCon nec
repSts [LastStmt _ e _ _]
= do { e2 <- repLE e
; z <- repNoBindSt e2
@@ -1709,7 +1659,6 @@ repSts (stmt@RecStmt{} : ss)
; z <- repRecSt (nonEmptyCoreList rss)
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
-repSts (XStmtLR nec : _) = noExtCon nec
repSts [] = return ([],[])
repSts other = notHandled "Exotic statement" (ppr other)
@@ -1730,8 +1679,6 @@ repBinds (HsIPBinds _ (IPBinds _ decs))
; return ([], core_list)
}
-repBinds (HsIPBinds _ (XHsIPBinds nec)) = noExtCon nec
-
repBinds (HsValBinds _ decs)
= do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
-- No need to worry about detailed scopes within
@@ -1744,7 +1691,6 @@ repBinds (HsValBinds _ decs)
; core_list <- coreListM decTyConName
(de_loc (sort_by_loc prs))
; return (ss, core_list) }
-repBinds (XHsLocalBindsLR nec) = noExtCon nec
rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
@@ -1755,7 +1701,6 @@ rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
; rhs' <- repE rhs
; ipb <- repImplicitParamBind name rhs'
; return (loc, ipb) }
-rep_implicit_param_bind (L _ (XIPBind nec)) = noExtCon nec
rep_implicit_param_name :: HsIPName -> MetaM (Core String)
rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
@@ -1800,8 +1745,6 @@ rep_bind (L loc (FunBind { fun_id = fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
; return (loc, ans) }
-rep_bind (L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec
-
rep_bind (L loc (PatBind { pat_lhs = pat
, pat_rhs = GRHSs _ guards (L _ wheres) }))
= do { patcore <- repLP pat
@@ -1810,7 +1753,6 @@ rep_bind (L loc (PatBind { pat_lhs = pat
; ans <- repVal patcore guardcore wherecore
; ans' <- wrapGenSyms ss ans
; return (loc, ans') }
-rep_bind (L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec
rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
= do { v' <- lookupBinder v
@@ -1860,9 +1802,6 @@ rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
wrapGenArgSyms (RecCon _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
-rep_bind (L _ (PatSynBind _ (XPatSynBind nec))) = noExtCon nec
-rep_bind (L _ (XHsBindsLR nec)) = noExtCon nec
-
repPatSynD :: Core TH.Name
-> Core (M TH.PatSynArgs)
-> Core (M TH.PatSynDir)
@@ -1900,7 +1839,6 @@ repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))
= do { clauses' <- mapM repClauseTup clauses
; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
-repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec
repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir))
repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
@@ -1939,9 +1877,6 @@ repLambda (L _ (Match { m_pats = ps
; lam <- addBinds ss (
do { xs <- repLPs ps; body <- repLE e; repLam xs body })
; wrapGenSyms ss lam }
-repLambda (L _ (Match { m_grhss = GRHSs _ [L _ (GRHS _ [] _)]
- (L _ (XHsLocalBindsLR nec)) } ))
- = noExtCon nec
repLambda (L _ m) = notHandled "Guarded lambdas" (pprMatch m)
@@ -2003,7 +1938,6 @@ repP (SigPat _ p t) = do { p' <- repLP p
; t' <- repLTy (hsSigWcType t)
; repPsig p' t' }
repP (SplicePat _ splice) = repSplice splice
-repP (XPat nec) = noExtCon nec
repP other = notHandled "Exotic pattern" (ppr other)
----------------------------------------------------------
@@ -2797,7 +2731,6 @@ repOverloadedLiteral (OverLit { ol_val = val})
-- The type Rational will be in the environment, because
-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
-- and rationalL is sucked in when any TH stuff is used
-repOverloadedLiteral (XOverLit nec) = noExtCon nec
mk_lit :: OverLitVal -> MetaM (HsLit GhcRn)
mk_lit (HsIntegral i) = mk_integer (il_value i)
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index a2e67f1170..b72336b4fc 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1,6 +1,7 @@
{-
Main functions for .hie file generation
-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -441,8 +442,6 @@ instance ProtectSig GhcTc where
instance ProtectSig GhcRn where
protectSig sc (HsWC a (HsIB b sig)) =
HsWC a (HsIB b (SH sc sig))
- protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec
- protectSig _ (XHsWildCardBndrs nec) = noExtCon nec
class HasLoc a where
-- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
@@ -457,7 +456,6 @@ instance HasLoc thing => HasLoc (PScoped thing) where
instance HasLoc (LHsQTyVars GhcRn) where
loc (HsQTvs _ vs) = loc vs
- loc _ = noSrcSpan
instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
loc (HsIB _ a) = loc a
@@ -488,7 +486,6 @@ instance HasLoc (HsDataDefn GhcRn) where
loc def@(HsDataDefn{}) = loc $ dd_cons def
-- Only used for data family instances, so we only need rhs
-- Most probably the rest will be unhelpful anyway
- loc _ = noSrcSpan
{- Note [Real DataCon Name]
The typechecker substitutes the conLikeWrapId for the name, but we don't want
@@ -753,7 +750,6 @@ instance ( a ~ GhcPass p
in toHie $ patScopes Nothing rhsScope NoScope pats
, toHie grhss
]
- XMatch nec -> noExtCon nec
instance ( ToHie (Context (Located (IdP a)))
) => ToHie (HsMatchContext a) where
@@ -842,7 +838,6 @@ instance ( a ~ GhcPass p
]
CoPat _ _ _ _ ->
[]
- XPat nec -> noExtCon nec
where
contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
contextify (InfixCon a b) = InfixCon a' b'
@@ -1039,7 +1034,6 @@ instance ( a ~ GhcPass p
[ toHie expr
]
Missing _ -> []
- XTupArg nec -> noExtCon nec
instance ( a ~ GhcPass p
, ToHie (PScoped (LPat a))
@@ -1081,7 +1075,6 @@ instance ( a ~ GhcPass p
RecStmt {recS_stmts = stmts} ->
[ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
]
- XStmtLR nec -> noExtCon nec
instance ( ToHie (LHsExpr a)
, ToHie (PScoped (LPat a))
@@ -1145,7 +1138,6 @@ instance ToHie (RFContext (LFieldOcc GhcRn)) where
FieldOcc name _ ->
[ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
]
- XFieldOcc nec -> noExtCon nec
instance ToHie (RFContext (LFieldOcc GhcTc)) where
toHie (RFC c rhs (L nspan f)) = concatM $ case f of
@@ -1153,7 +1145,6 @@ instance ToHie (RFContext (LFieldOcc GhcTc)) where
let var' = setVarName var (removeDefSrcSpan $ varName var)
in [ toHie $ C (RecField c rhs) (L nspan var')
]
- XFieldOcc nec -> noExtCon nec
instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
@@ -1162,7 +1153,6 @@ instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
]
Ambiguous _name _ ->
[ ]
- XAmbiguousFieldOcc nec -> noExtCon nec
instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
@@ -1174,7 +1164,6 @@ instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
let var' = setVarName var (removeDefSrcSpan $ varName var)
in [ toHie $ C (RecField c rhs) (L nspan var')
]
- XAmbiguousFieldOcc nec -> noExtCon nec
instance ( a ~ GhcPass p
, ToHie (PScoped (LPat a))
@@ -1193,7 +1182,6 @@ instance ( a ~ GhcPass p
[ toHie $ listScopes NoScope stmts
, toHie $ PS Nothing sc NoScope pat
]
- toHie (RS _ (XApplicativeArg nec)) = noExtCon nec
instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
toHie (PrefixCon args) = toHie args
@@ -1271,7 +1259,6 @@ instance ToHie (TyClGroup GhcRn) where
, toHie roles
, toHie instances
]
- toHie (XTyClGroup nec) = noExtCon nec
instance ToHie (LTyClDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
@@ -1317,7 +1304,6 @@ instance ToHie (LTyClDecl GhcRn) where
context_scope = mkLScope context
rhs_scope = foldl1' combineScopes $ map mkScope
[ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
- XTyClDecl nec -> noExtCon nec
instance ToHie (LFamilyDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
@@ -1332,7 +1318,6 @@ instance ToHie (LFamilyDecl GhcRn) where
rhsSpan = sigSpan `combineScopes` injSpan
sigSpan = mkScope $ getLoc sig
injSpan = maybe NoScope (mkScope . getLoc) inj
- XFamilyDecl nec -> noExtCon nec
instance ToHie (FamilyInfo GhcRn) where
toHie (ClosedTypeFamily (Just eqns)) = concatM $
@@ -1353,7 +1338,6 @@ instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
TyVarSig _ bndr ->
[ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
]
- XFamilyResultSig nec -> noExtCon nec
instance ToHie (Located (FunDep (Located Name))) where
toHie (L span fd@(lhs, rhs)) = concatM $
@@ -1377,7 +1361,6 @@ instance (ToHie rhs, HasLoc rhs)
where scope = combineScopes patsScope rhsScope
patsScope = mkScope (loc pats)
rhsScope = mkScope (loc rhs)
- toHie (XFamEqn nec) = noExtCon nec
instance ToHie (LInjectivityAnn GhcRn) where
toHie (L span ann) = concatM $ makeNode ann span : case ann of
@@ -1393,7 +1376,6 @@ instance ToHie (HsDataDefn GhcRn) where
, toHie cons
, toHie derivs
]
- toHie (XHsDataDefn nec) = noExtCon nec
instance ToHie (HsDeriving GhcRn) where
toHie (L span clauses) = concatM
@@ -1408,7 +1390,6 @@ instance ToHie (LHsDerivingClause GhcRn) where
, pure $ locOnly ispan
, toHie $ map (TS (ResolvedScopes [])) tys
]
- XHsDerivingClause nec -> noExtCon nec
instance ToHie (Located (DerivStrategy GhcRn)) where
toHie (L span strat) = concatM $ makeNode strat span : case strat of
@@ -1446,7 +1427,6 @@ instance ToHie (LConDecl GhcRn) where
rhsScope = combineScopes ctxScope argsScope
ctxScope = maybe NoScope mkLScope ctx
argsScope = condecl_scope dets
- XConDecl nec -> noExtCon nec
where condecl_scope args = case args of
PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
@@ -1466,7 +1446,6 @@ instance ( HasLoc thing
, toHie $ TS sc a
]
where span = loc a
- toHie (TS _ (XHsImplicitBndrs nec)) = noExtCon nec
instance ( HasLoc thing
, ToHie (TScoped thing)
@@ -1476,7 +1455,6 @@ instance ( HasLoc thing
, toHie $ TS sc a
]
where span = loc a
- toHie (TS _ (XHsWildCardBndrs nec)) = noExtCon nec
instance ToHie (LStandaloneKindSig GhcRn) where
toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]
@@ -1487,7 +1465,6 @@ instance ToHie (StandaloneKindSig GhcRn) where
[ toHie $ C TyDecl name
, toHie $ TS (ResolvedScopes []) typ
]
- XStandaloneKindSig nec -> noExtCon nec
instance ToHie (SigContext (LSig GhcRn)) where
toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
@@ -1531,7 +1508,6 @@ instance ToHie (SigContext (LSig GhcRn)) where
, toHie $ map (C Use) names
, toHie $ fmap (C Use) typ
]
- XSig nec -> noExtCon nec
instance ToHie (LHsType GhcRn) where
toHie x = toHie $ TS (ResolvedScopes []) x
@@ -1623,7 +1599,6 @@ instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
[ toHie $ C (TyVarBind sc tsc) var
, toHie kind
]
- XTyVarBndr nec -> noExtCon nec
instance ToHie (TScoped (LHsQTyVars GhcRn)) where
toHie (TS sc (HsQTvs implicits vars)) = concatM $
@@ -1633,7 +1608,6 @@ instance ToHie (TScoped (LHsQTyVars GhcRn)) where
where
varLoc = loc vars
bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
- toHie (TS _ (XLHsQTyVars nec)) = noExtCon nec
instance ToHie (LHsContext GhcRn) where
toHie (L span tys) = concatM $
@@ -1647,7 +1621,6 @@ instance ToHie (LConDeclField GhcRn) where
[ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
, toHie typ
]
- XConDeclField nec -> noExtCon nec
instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
toHie (From expr) = toHie expr
@@ -1670,7 +1643,6 @@ instance ToHie (LSpliceDecl GhcRn) where
SpliceDecl _ splice _ ->
[ toHie splice
]
- XSpliceDecl nec -> noExtCon nec
instance ToHie (HsBracket a) where
toHie _ = pure []
@@ -1717,8 +1689,10 @@ instance ( a ~ GhcPass p
HsSpliced _ _ _ ->
[]
XSplice x -> case ghcPass @p of
+#if __GLASGOW_HASKELL__ < 811
GhcPs -> noExtCon x
GhcRn -> noExtCon x
+#endif
GhcTc -> case x of
HsSplicedT _ -> []
@@ -1728,7 +1702,6 @@ instance ToHie (LRoleAnnotDecl GhcRn) where
[ toHie $ C Use var
, concatMapM (pure . locOnly . getLoc) roles
]
- XRoleAnnotDecl nec -> noExtCon nec
instance ToHie (LInstDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
@@ -1741,7 +1714,6 @@ instance ToHie (LInstDecl GhcRn) where
TyFamInstD _ d ->
[ toHie $ L span d
]
- XInstDecl nec -> noExtCon nec
instance ToHie (LClsInstDecl GhcRn) where
toHie (L span decl) = concatM
@@ -1775,21 +1747,18 @@ instance ToHie (LDerivDecl GhcRn) where
, toHie strat
, toHie overlap
]
- XDerivDecl nec -> noExtCon nec
instance ToHie (LFixitySig GhcRn) where
toHie (L span sig) = concatM $ makeNode sig span : case sig of
FixitySig _ vars _ ->
[ toHie $ map (C Use) vars
]
- XFixitySig nec -> noExtCon nec
instance ToHie (LDefaultDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
DefaultDecl _ typs ->
[ toHie typs
]
- XDefaultDecl nec -> noExtCon nec
instance ToHie (LForeignDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
@@ -1803,7 +1772,6 @@ instance ToHie (LForeignDecl GhcRn) where
, toHie $ TS (ResolvedScopes []) sig
, toHie fe
]
- XForeignDecl nec -> noExtCon nec
instance ToHie ForeignImport where
toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
@@ -1823,14 +1791,12 @@ instance ToHie (LWarnDecls GhcRn) where
Warnings _ _ warnings ->
[ toHie warnings
]
- XWarnDecls nec -> noExtCon nec
instance ToHie (LWarnDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
Warning _ vars _ ->
[ toHie $ map (C Use) vars
]
- XWarnDecl nec -> noExtCon nec
instance ToHie (LAnnDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
@@ -1838,7 +1804,6 @@ instance ToHie (LAnnDecl GhcRn) where
[ toHie prov
, toHie expr
]
- XAnnDecl nec -> noExtCon nec
instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
toHie (ValueAnnProvenance a) = toHie $ C Use a
@@ -1850,10 +1815,8 @@ instance ToHie (LRuleDecls GhcRn) where
HsRules _ _ rules ->
[ toHie rules
]
- XRuleDecls nec -> noExtCon nec
instance ToHie (LRuleDecl GhcRn) where
- toHie (L _ (XRuleDecl nec)) = noExtCon nec
toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
[ makeNode r span
, pure $ locOnly $ getLoc rname
@@ -1876,7 +1839,6 @@ instance ToHie (RScoped (LRuleBndr GhcRn)) where
[ toHie $ C (ValBind RegularBind sc Nothing) var
, toHie $ TS (ResolvedScopes [sc]) typ
]
- XRuleBndr nec -> noExtCon nec
instance ToHie (LImportDecl GhcRn) where
toHie (L span decl) = concatM $ makeNode decl span : case decl of
@@ -1885,7 +1847,6 @@ instance ToHie (LImportDecl GhcRn) where
, toHie $ fmap (IEC ImportAs) as
, maybe (pure []) goIE hidden
]
- XImportDecl nec -> noExtCon nec
where
goIE (hiding, (L sp liens)) = concatM $
[ pure $ locOnly sp
@@ -1916,7 +1877,6 @@ instance ToHie (IEContext (LIE GhcRn)) where
IEGroup _ _ _ -> []
IEDoc _ _ -> []
IEDocNamed _ _ -> []
- XIE nec -> noExtCon nec
instance ToHie (IEContext (LIEWrappedName Name)) where
toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index f1e10fc323..b8dbfd1e1c 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -219,19 +219,15 @@ rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do
(thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds
return (thing, fvs_thing `plusFV` fv_binds)
-rnLocalBindsAndThen (XHsLocalBindsLR nec) _ = noExtCon nec
-
rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)
rnIPBinds (IPBinds _ ip_binds ) = do
(ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
return (IPBinds noExtField ip_binds', plusFVs fvs_s)
-rnIPBinds (XHsIPBinds nec) = noExtCon nec
rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
rnIPBind (IPBind _ ~(Left n) expr) = do
(expr',fvExpr) <- rnLExpr expr
return (IPBind noExtField (Left n) expr', fvExpr)
-rnIPBind (XIPBind nec) = noExtCon nec
{-
************************************************************************
@@ -630,10 +626,10 @@ makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
where
+ add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv
add_one_sig env (L loc (FixitySig _ names fixity)) =
foldlM add_one env [ (loc,name_loc,name,fixity)
| L name_loc name <- names ]
- add_one_sig _ (L _ (XFixitySig nec)) = noExtCon nec
add_one env (loc, name_loc, name,fixity) = do
{ -- this fixity decl is a duplicate iff
@@ -744,8 +740,6 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
= hang (text "Illegal pattern synonym declaration")
2 (text "Use -XPatternSynonyms to enable this extension")
-rnPatSynBind _ (XPatSynBind nec) = noExtCon nec
-
{-
Note [Renaming pattern synonym variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1047,8 +1041,6 @@ renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
text "A COMPLETE pragma must mention at least one data constructor" $$
text "or pattern synonym defined in the same module."
-renameSig _ (XSig nec) = noExtCon nec
-
{-
Note [Orphan COMPLETE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1115,8 +1107,6 @@ okHsSig ctxt (L _ sig)
(CompleteMatchSig {}, TopSigCtxt {} ) -> True
(CompleteMatchSig {}, _) -> False
- (XSig nec, _) -> noExtCon nec
-
-------------------
findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]
-- Check for duplicates on RdrName version,
@@ -1171,7 +1161,6 @@ rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
; return (mkMatchGroup origin new_ms, ms_fvs) }
-rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec
rnMatch :: Outputable (body GhcPs) => HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
@@ -1193,7 +1182,6 @@ rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
_ -> ctxt
; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats'
, m_grhss = grhss'}, grhss_fvs ) }}
-rnMatch' _ _ (XMatch nec) = noExtCon nec
emptyCaseErr :: HsMatchContext GhcRn -> SDoc
emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
@@ -1220,7 +1208,6 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))
= rnLocalBindsAndThen binds $ \ binds' _ -> do
(grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
return (GRHSs noExtField grhss' (L l binds'), fvGRHSs)
-rnGRHSs _ _ (XGRHSs nec) = noExtCon nec
rnGRHS :: HsMatchContext GhcRn
-> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
@@ -1248,7 +1235,6 @@ rnGRHS' ctxt rnBody (GRHS _ guards rhs)
is_standard_guard [] = True
is_standard_guard [L _ (BodyStmt {})] = True
is_standard_guard _ = False
-rnGRHS' _ _ (XGRHS nec) = noExtCon nec
{-
*********************************************************
@@ -1272,7 +1258,6 @@ rnSrcFixityDecl sig_ctxt = rn_decl
rn_decl (FixitySig _ fnames fixity)
= do names <- concatMapM lookup_one fnames
return (FixitySig noExtField names fixity)
- rn_decl (XFixitySig nec) = noExtCon nec
lookup_one :: Located RdrName -> RnM [Located Name]
lookup_one (L name_loc rdr_name)
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index d091dc66fa..20163e9d65 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -241,7 +241,6 @@ rnExpr (HsPragE x prag expr)
rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann
rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl
rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo
- rn_prag (XHsPragE x) = noExtCon x
rnExpr (HsLam x matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
@@ -289,7 +288,6 @@ rnExpr (ExplicitTuple x tup_args boxity)
; return (L l (Present x e'), fvs) }
rnTupArg (L l (Missing _)) = return (L l (Missing noExtField)
, emptyFVs)
- rnTupArg (L _ (XTupArg nec)) = noExtCon nec
rnExpr (ExplicitSum x alt arity expr)
= do { (expr', fvs) <- rnLExpr expr
@@ -441,7 +439,6 @@ rnCmdTop = wrapLocFstM rnCmdTop'
; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
fvCmd `plusFV` cmd_fvs) }
- rnCmdTop' (XCmdTop nec) = noExtCon nec
rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
rnLCmd = wrapLocFstM rnCmd
@@ -514,8 +511,6 @@ rnCmd (HsCmdDo x (L l stmts))
rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
; return ( HsCmdDo x (L l stmts'), fvs ) }
-rnCmd (XCmd nec) = noExtCon nec
-
---------------------------------------------------
type CmdNeeds = FreeVars -- Only inhabitants are
-- appAName, choiceAName, loopAName
@@ -545,8 +540,6 @@ methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match
methodNamesCmd (HsCmdCase _ _ matches)
= methodNamesMatch matches `addOneFV` choiceAName
-methodNamesCmd (XCmd nec) = noExtCon nec
-
--methodNamesCmd _ = emptyFVs
-- Other forms can't occur in commands, but it's not convenient
-- to error here so we just do what's convenient.
@@ -558,20 +551,16 @@ methodNamesMatch (MG { mg_alts = L _ ms })
= plusFVs (map do_one ms)
where
do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
- do_one (L _ (XMatch nec)) = noExtCon nec
-methodNamesMatch (XMatchGroup nec) = noExtCon nec
-------------------------------------------------
-- gaw 2004
methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
-methodNamesGRHSs (XGRHSs nec) = noExtCon nec
-------------------------------------------------
methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
-methodNamesGRHS (L _ (XGRHS nec)) = noExtCon nec
---------------------------------------------------
methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars
@@ -593,7 +582,6 @@ methodNamesStmt (TransStmt {}) = emptyFVs
methodNamesStmt ApplicativeStmt{} = emptyFVs
-- ParStmt and TransStmt can't occur in commands, but it's not
-- convenient to error here so we just do what's convenient
-methodNamesStmt (XStmtLR nec) = noExtCon nec
{-
************************************************************************
@@ -923,9 +911,6 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
rnStmt _ _ (L _ ApplicativeStmt{}) _ =
panic "rnStmt: ApplicativeStmt"
-rnStmt _ _ (L _ (XStmtLR nec)) _ =
- noExtCon nec
-
rnParallelStmts :: forall thing. HsStmtContext GhcRn
-> SyntaxExpr GhcRn
-> [ParStmtBlock GhcPs GhcPs]
@@ -955,7 +940,6 @@ rnParallelStmts ctxt return_op segs thing_inside
; let seg' = ParStmtBlock x stmts' used_bndrs return_op
; return ((seg':segs', thing), fvs) }
- rn_segs _ _ (XParStmtBlock nec:_) = noExtCon nec
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
@@ -1124,10 +1108,6 @@ rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))
= panic "rn_rec_stmt LetStmt EmptyLocalBinds"
-rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))))
- = noExtCon nec
-rn_rec_stmt_lhs _ (L _ (XStmtLR nec))
- = noExtCon nec
rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
-> [LStmt GhcPs body]
@@ -1195,18 +1175,12 @@ rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo
rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
-rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))), _)
- = noExtCon nec
-
rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)
= panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
= pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
-rn_rec_stmt _ _ (L _ (XStmtLR nec), _)
- = noExtCon nec
-
rn_rec_stmts :: Outputable (body GhcPs) =>
(Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
-> [Name]
@@ -1854,7 +1828,6 @@ isStrictPattern lpat =
NPlusKPat{} -> True
SplicePat{} -> True
CoPat{} -> panic "isStrictPattern: CoPat"
- XPat nec -> noExtCon nec
{-
Note [ApplicativeDo and refutable patterns]
@@ -2065,7 +2038,6 @@ pprStmtCat (LetStmt {}) = text "let"
pprStmtCat (RecStmt {}) = text "rec"
pprStmtCat (ParStmt {}) = text "parallel"
pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
-pprStmtCat (XStmtLR nec) = noExtCon nec
------------
emptyInvalid :: Validity -- Payload is the empty document
@@ -2131,7 +2103,6 @@ okCompStmt dflags _ stmt
RecStmt {} -> emptyInvalid
LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt)
ApplicativeStmt {} -> emptyInvalid
- XStmtLR nec -> noExtCon nec
---------
checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs
index 9400c0582f..b86be35160 100644
--- a/compiler/GHC/Rename/Fixity.hs
+++ b/compiler/GHC/Rename/Fixity.hs
@@ -216,4 +216,3 @@ lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr)
format_ambig (elt, fix) = hang (ppr fix)
2 (pprNameProvenance elt)
-lookupFieldFixityRn (XAmbiguousFieldOcc nec) = noExtCon nec
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index f269653c62..9def0b83e3 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -137,10 +137,6 @@ rn_hs_sig_wc_type scoping ctxt
, hsib_body = hs_ty' }
; (res, fvs2) <- thing_inside sig_ty'
; return (res, fvs1 `plusFV` fvs2) } }
-rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs nec)) _
- = noExtCon nec
-rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _
- = noExtCon nec
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
@@ -149,7 +145,6 @@ rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
; return (sig_ty', fvs) }
-rnHsWcType _ (XHsWildCardBndrs nec) = noExtCon nec
rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
@@ -311,7 +306,6 @@ rnHsSigType ctx level (HsIB { hsib_body = hs_ty })
; return ( HsIB { hsib_ext = vars
, hsib_body = body' }
, fvs ) } }
-rnHsSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec
rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables
-- E.g. f :: forall a. a->b
@@ -986,8 +980,6 @@ bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind))
$ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind'))
; return (b, fvs1 `plusFV` fvs2) }
-bindLHsTyVarBndr _ _ (L _ (XTyVarBndr nec)) _ = noExtCon nec
-
newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
newTyVarNameRn mb_assoc (L loc rdr)
= do { rdr_env <- getLocalRdrEnv
@@ -1035,8 +1027,6 @@ rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
where
lbl = occNameFS $ rdrNameOcc rdr
fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
- lookupField (XFieldOcc nec) = noExtCon nec
-rnField _ _ (L _ (XConDeclField nec)) = noExtCon nec
{-
************************************************************************
@@ -1278,7 +1268,6 @@ checkPrecMatch op (MG { mg_alts = (L _ ms) })
-- but the second eqn has no args (an error, but not discovered
-- until the type checker). So we don't want to crash on the
-- second eqn.
-checkPrecMatch _ (XMatchGroup nec) = noExtCon nec
checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
@@ -1659,7 +1648,6 @@ extractRdrKindSigVars (L _ resultSig)
extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVarsNoDups
extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })
= maybe [] extractHsTyRdrTyVars ksig
-extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec
extract_lctxt :: LHsContext GhcPs
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 89bc307809..dd14b33275 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -234,7 +234,6 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls,
traceRn "finish Dus" (ppr src_dus ) ;
return (final_tcg_env, rn_group)
}}}}
-rnSrcDecls (XHsGroup nec) = noExtCon nec
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
-- This function could be defined lower down in the module hierarchy,
@@ -302,7 +301,6 @@ rnSrcWarnDecls bndr_set decls'
= do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
rdr_names
; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
- rn_deprec (XWarnDecl nec) = noExtCon nec
what = text "deprecation"
@@ -338,7 +336,6 @@ rnAnnDecl ann@(HsAnnotation _ s provenance expr)
rnLExpr expr
; return (HsAnnotation noExtField s provenance' expr',
provenance_fvs `plusFV` expr_fvs) }
-rnAnnDecl (XAnnDecl nec) = noExtCon nec
rnAnnProvenance :: AnnProvenance RdrName
-> RnM (AnnProvenance Name, FreeVars)
@@ -360,7 +357,6 @@ rnDefaultDecl (DefaultDecl _ tys)
; return (DefaultDecl noExtField tys', fvs) }
where
doc_str = DefaultDeclCtx
-rnDefaultDecl (XDefaultDecl nec) = noExtCon nec
{-
*********************************************************
@@ -395,8 +391,6 @@ rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
-- we add it to the free-variable list. It might, for example,
-- be imported from another module
-rnHsForeignDecl (XForeignDecl nec) = noExtCon nec
-
-- | For Windows DLLs we need to know what packages imported symbols are from
-- to generate correct calls. Imported symbols are tagged with the current
-- package, so if they get inlined across a package boundary we'll still
@@ -442,8 +436,6 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid })
; traceRn "rnSrcIstDecl end }" empty
; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) }
-rnSrcInstDecl (XInstDecl nec) = noExtCon nec
-
-- | Warn about non-canonical typeclass instance declarations
--
-- A "non-canonical" instance definition can occur for instances of a
@@ -667,7 +659,6 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
-- the instance context after renaming. This is a bit
-- strange, but should not matter (and it would be more work
-- to remove the context).
-rnClsInstDecl (XClsInstDecl nec) = noExtCon nec
rnFamInstEqn :: HsDocContext
-> AssocTyFamInfo
@@ -756,8 +747,6 @@ rnFamInstEqn doc atfi rhs_kvars
, feqn_fixity = fixity
, feqn_rhs = payload' } },
all_fvs) }
-rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec
-rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec
rnTyFamInstDecl :: AssocTyFamInfo
-> TyFamInstDecl GhcPs
@@ -805,8 +794,6 @@ rnTyFamInstEqn atfi ctf_info
withHsDocContext (TyFamilyCtx fam_rdr_name) $
wrongTyFamName fam_name tycon'
; pure (eqn', fvs) }
-rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec
-rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec
rnTyFamDefltDecl :: Name
-> TyFamDefltDecl GhcPs
@@ -823,10 +810,6 @@ rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
; (eqn', fvs) <-
rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn
; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
-rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec)))
- = noExtCon nec
-rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec))
- = noExtCon nec
-- Renaming of the associated types in instances.
@@ -980,7 +963,6 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
; return (DerivDecl noExtField ty' mds' overlap, fvs) }
where
loc = getLoc $ hsib_body $ hswc_body ty
-rnSrcDerivDecl (XDerivDecl nec) = noExtCon nec
standaloneDerivErr :: SDoc
standaloneDerivErr
@@ -1002,7 +984,6 @@ rnHsRuleDecls (HsRules { rds_src = src
; return (HsRules { rds_ext = noExtField
, rds_src = src
, rds_rules = rn_rules }, fvs) }
-rnHsRuleDecls (XRuleDecls nec) = noExtCon nec
rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
rnHsRuleDecl (HsRule { rd_name = rule_name
@@ -1029,11 +1010,10 @@ rnHsRuleDecl (HsRule { rd_name = rule_name
, rd_lhs = lhs'
, rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } }
where
+ get_var :: RuleBndr GhcPs -> Located RdrName
get_var (RuleBndrSig _ v _) = v
get_var (RuleBndr _ v) = v
- get_var (XRuleBndr nec) = noExtCon nec
in_rule = text "in the rule" <+> pprFullRuleName rule_name
-rnHsRuleDecl (XRuleDecl nec) = noExtCon nec
bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
-> [LRuleBndr GhcPs] -> [Name]
@@ -1397,7 +1377,6 @@ rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)
standaloneKiSigErr =
hang (text "Illegal standalone kind signature")
2 (text "Did you mean to enable StandaloneKindSignatures?")
-rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec
depAnalTyClDecls :: GlobalRdrEnv
-> KindSig_FV_Env
@@ -1466,7 +1445,6 @@ rnRoleAnnots tc_names role_annots
(text "role annotation")
tycon
; return $ RoleAnnotDecl noExtField tycon' roles }
- rn_role_annot1 (XRoleAnnotDecl nec) = noExtCon nec
dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
dupRoleAnnotErr list
@@ -1590,7 +1568,6 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
, tcdRhs = rhs', tcdSExt = fvs }, fvs) } }
-- "data", "newtype" declarations
-rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
rnTyClDecl (DataDecl
{ tcdLName = tycon, tcdTyVars = tyvars,
tcdFixity = fixity,
@@ -1677,8 +1654,6 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
where
cls_doc = ClassDeclCtx lcls
-rnTyClDecl (XTyClDecl nec) = noExtCon nec
-
-- Does the data type declaration include a CUSK?
data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool
data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do
@@ -1761,7 +1736,6 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
multipleDerivClausesErr
; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds
; return (L loc ds', fvs) }
-rnDataDefn _ (XHsDataDefn nec) = noExtCon nec
warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
-> SrcSpan
@@ -1800,8 +1774,6 @@ rnLHsDerivingClause doc
, deriv_clause_strategy = dcs'
, deriv_clause_tys = L loc' dct' })
, fvs ) }
-rnLHsDerivingClause _ (L _ (XHsDerivingClause nec))
- = noExtCon nec
rnLDerivStrategy :: forall a.
HsDocContext
@@ -1912,7 +1884,6 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
= return (ClosedTypeFamily Nothing, emptyFVs)
rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
rn_info _ DataFamily = return (DataFamily, emptyFVs)
-rnFamDecl _ (XFamilyDecl nec) = noExtCon nec
rnFamResultSig :: HsDocContext
-> FamilyResultSig GhcPs
@@ -1944,7 +1915,6 @@ rnFamResultSig doc (TyVarSig _ tvbndr)
-- scoping checks that are irrelevant here
tvbndr $ \ tvbndr' ->
return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) }
-rnFamResultSig _ (XFamilyResultSig nec) = noExtCon nec
-- Note [Renaming injectivity annotation]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2154,8 +2124,6 @@ rnConDecl decl@(ConDeclGADT { con_names = names
, con_doc = mb_doc' },
all_fvs) } }
-rnConDecl (XConDecl nec) = noExtCon nec
-
rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
-> RnM (Maybe (LHsContext GhcRn), FreeVars)
@@ -2348,9 +2316,6 @@ add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
add gp l (DocD _ d) ds
= addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
-add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec
-add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec
-add (XHsGroup nec) _ _ _ = noExtCon nec
add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
@@ -2363,7 +2328,6 @@ add_tycld d [] = [TyClGroup { group_ext = noExtField
]
add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
= ds { group_tyclds = d : tyclds } : dss
-add_tycld _ (XTyClGroup nec: _) = noExtCon nec
add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
@@ -2376,7 +2340,6 @@ add_instd d [] = [TyClGroup { group_ext = noExtField
]
add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
= ds { group_instds = d : instds } : dss
-add_instd _ (XTyClGroup nec: _) = noExtCon nec
add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
@@ -2389,7 +2352,6 @@ add_role_annot d [] = [TyClGroup { group_ext = noExtField
]
add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
= tycls { group_roles = d : roles } : rest
-add_role_annot _ (XTyClGroup nec: _) = noExtCon nec
add_kisig :: LStandaloneKindSig (GhcPass p)
-> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
@@ -2402,7 +2364,6 @@ add_kisig d [] = [TyClGroup { group_ext = noExtField
]
add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest)
= tycls { group_kisigs = d : kisigs } : rest
-add_kisig _ (XTyClGroup nec : _) = noExtCon nec
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 5a5c7f1950..bf2f15829e 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -388,7 +388,6 @@ rnImportDecl this_mod
, ideclHiding = new_imp_details })
return (new_imp_decl, gbl_env, imports, mi_hpc iface)
-rnImportDecl _ (L _ (XImportDecl nec)) = noExtCon nec
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
@@ -765,7 +764,6 @@ getLocalNonValBinders fixity_env
= expectJust "getLocalNonValBinders/find_con_decl_fld" $
find (\ fl -> flLabel fl == lbl) flds
where lbl = occNameFS (rdrNameOcc rdr)
- find_con_decl_fld (L _ (XFieldOcc nec)) = noExtCon nec
new_assoc :: Bool -> LInstDecl GhcPs
-> RnM ([AvailInfo], [(Name, [FieldLabel])])
@@ -801,8 +799,6 @@ getLocalNonValBinders fixity_env
(avails, fldss)
<- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts
pure (avails, concat fldss)
- new_assoc _ (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec
- new_assoc _ (L _ (XInstDecl nec)) = noExtCon nec
new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
@@ -816,16 +812,13 @@ getLocalNonValBinders fixity_env
-- main_name is not bound here!
fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
; return (avail, fld_env) }
- new_di _ _ (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec
new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs
-> RnM (AvailInfo, [(Name, [FieldLabel])])
new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
-getLocalNonValBinders _ (XHsGroup nec) = noExtCon nec
newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
-newRecordSelector _ _ (L _ (XFieldOcc nec)) = noExtCon nec
newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))
= do { selName <- newTopSrcBinder $ L loc $ field
; return $ qualFieldLbl { flSelector = selName } }
@@ -1438,7 +1431,6 @@ findImportUsage imports used_gres
-- If you use 'signum' from Num, then the user may well have
-- imported Num(signum). We don't want to complain that
-- Num is not itself mentioned. Hence the two cases in add_unused_with.
- unused_decl (L _ (XImportDecl nec)) = noExtCon nec
{- Note [The ImportMap]
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index c8a2cbb023..166d46a05f 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -638,8 +638,6 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
sel (L ll lbl)))
, hsRecFieldArg = arg'
, hsRecPun = pun })) }
- rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _))
- = panic "rnHsRecFields"
rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 5c7d287a38..560b908bbc 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -182,8 +182,6 @@ rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"
rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e
; return (TExpBr x e', fvs) }
-rn_bracket _ (XBracket nec) = noExtCon nec
-
quotationCtxtDoc :: HsBracket GhcPs -> SDoc
quotationCtxtDoc br_body
= hang (text "In the Template Haskell quotation")
@@ -300,7 +298,6 @@ checkTopSpliceAllowed splice = do
spliceExtension (HsTypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell)
spliceExtension (HsUntypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell)
spliceExtension s@(HsSpliced {}) = pprPanic "spliceExtension" (ppr s)
- spliceExtension (XSplice nec) = noExtCon nec
------------------
@@ -322,7 +319,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)
- XSplice nec -> noExtCon nec
-- Typecheck the expression
; meta_exp_ty <- tcMetaTy meta_ty_name
@@ -369,8 +365,6 @@ makePending _ splice@(HsTypedSplice {})
= pprPanic "makePending" (ppr splice)
makePending _ splice@(HsSpliced {})
= pprPanic "makePending" (ppr splice)
-makePending _ (XSplice nec)
- = noExtCon nec
------------------
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
@@ -420,7 +414,6 @@ rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)
, unitFV quoter') }
rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)
-rnSplice (XSplice nec) = noExtCon nec
---------------------
rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
@@ -653,7 +646,6 @@ rnSpliceDecl (SpliceDecl _ (L loc splice) flg)
, SpliceDecl noExtField (L loc rn_splice) flg)
run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)
-rnSpliceDecl (XSpliceDecl nec) = noExtCon nec
rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
-- Declaration splice at the very top level of the module
@@ -731,7 +723,6 @@ spliceCtxt splice
HsTypedSplice {} -> text "typed splice:"
HsQuasiQuote {} -> text "quasi-quotation:"
HsSpliced {} -> text "spliced expression:"
- XSplice nec -> noExtCon nec
-- | The splice data to be logged
data SpliceInfo
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
{-
************************************************************************
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index d2e9c3cd6e..5df15f2b7c 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -605,8 +605,6 @@ cvtConstr (ForallC tvs ctxt con)
where
all_tvs = hsQTvExplicit tvs' ++ ex_tvs
- add_forall _ _ (XConDecl nec) = noExtCon nec
-
cvtConstr (GadtC [] _strtys _ty)
= failWith (text "GadtC must have at least one constructor name")
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index 67eddf1f2a..7e0b07ede6 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -119,10 +119,10 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
sig_info (ClassOpSig {}) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
+ import_info :: LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int)
import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
, ideclAs = as, ideclHiding = spec }))
= add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
- import_info (L _ (XImportDecl nec)) = noExtCon nec
safe_info False = 0
safe_info True = 1
@@ -149,6 +149,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))
class_info _ = (0,0)
+ inst_info :: InstDecl GhcPs -> (Int, Int, Int, Int, Int)
inst_info (TyFamInstD {}) = (0,0,0,1,0)
inst_info (DataFamInstD {}) = (0,0,0,0,1)
inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths
@@ -161,8 +162,6 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
ss, is, length ats, length adts)
where
methods = map unLoc $ bagToList inst_meths
- inst_info (ClsInstD _ (XClsInstDecl nec)) = noExtCon nec
- inst_info (XInstDecl nec) = noExtCon nec
-- TODO: use Sum monoid
addpr :: (Int,Int,Int) -> Int
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 485d1bf80e..5efe975f11 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -495,7 +495,6 @@ has_args (L _ (Match { m_pats = args }) : _) = not (null args)
-- no arguments. This is necessary now that variable bindings
-- with no arguments are now treated as FunBinds rather
-- than pattern bindings (tests/rename/should_fail/rnfail002).
-has_args (L _ (XMatch nec) : _) = noExtCon nec
{- **********************************************************************
@@ -2540,8 +2539,6 @@ mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs
mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)
= HsRecField (L loc (Unambiguous noExtField rdr)) arg pun
-mk_rec_upd_field (HsRecField (L _ (XFieldOcc nec)) _ _)
- = noExtCon nec
mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation
-> InlinePragma
diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs
index 02ce817566..b3b4c85cca 100644
--- a/testsuite/tests/ghc-api/annotations/stringSource.hs
+++ b/testsuite/tests/ghc-api/annotations/stringSource.hs
@@ -87,7 +87,6 @@ testOneFile libdir fileName = do
doPragE (HsPragCore _ src ss) = [("co",[conv (noLoc ss)])]
doPragE (HsPragSCC _ src ss) = [("sc",[conv (noLoc ss)])]
doPragE (HsPragTick _ src (ss,_,_) _ss2) = [("tp",[conv (noLoc ss)])]
- doPragE (XHsPragE x) = noExtCon x
conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs)
diff --git a/utils/haddock b/utils/haddock
-Subproject 38036137bce2587c6d50756f6fab8cfafeb5a63
+Subproject 5ec817a3e41b7eaa50c74701ab2d7642df86464