diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2020-03-27 17:22:28 -0400 |
|---|---|---|
| committer | Ryan Scott <ryan.gl.scott@gmail.com> | 2020-04-07 19:43:20 -0400 |
| commit | 04b6cf947ea065a210a216cc91f918cc1660d430 (patch) | |
| tree | 60d3192ca3997385988bab216707193cb4c3c2da /compiler/GHC | |
| parent | 255418da5d264fb2758bc70925adb2094f34adc3 (diff) | |
| download | haskell-04b6cf947ea065a210a216cc91f918cc1660d430.tar.gz | |
Make NoExtCon fields strictwip/strict-NoExtCon
This changes every unused TTG extension constructor to be strict in
its field so that the pattern-match coverage checker is smart enough
any such constructors are unreachable in pattern matches. This lets
us remove nearly every use of `noExtCon` in the GHC API. The only
ones we cannot remove are ones underneath uses of `ghcPass`, but that
is only because GHC 8.8's and 8.10's coverage checkers weren't smart
enough to perform this kind of reasoning. GHC HEAD's coverage
checker, on the other hand, _is_ smart enough, so we guard these uses
of `noExtCon` with CPP for now.
Bumps the `haddock` submodule.
Fixes #17992.
Diffstat (limited to 'compiler/GHC')
53 files changed, 104 insertions, 686 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") |