From 151b14d4b152daa70f11b3d09ec2307f4c375f01 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 4 Apr 2018 21:43:25 +0200 Subject: WIP on TTG for HsBinds --- compiler/deSugar/Coverage.hs | 10 ++- compiler/deSugar/DsBinds.hs | 7 +- compiler/deSugar/DsExpr.hs | 9 +- compiler/deSugar/DsMeta.hs | 24 +++--- compiler/hsSyn/Convert.hs | 21 ++--- compiler/hsSyn/HsBinds.hs | 171 ++++++++++++++++++++++++++----------- compiler/hsSyn/HsExtension.hs | 112 ++++++++++++++++++++++-- compiler/hsSyn/HsUtils.hs | 16 ++-- compiler/parser/Parser.y | 38 ++++----- compiler/parser/RdrHsSyn.hs | 4 +- compiler/rename/RnBinds.hs | 104 ++++++++++++---------- compiler/rename/RnExpr.hs | 6 +- compiler/rename/RnNames.hs | 2 +- compiler/rename/RnSource.hs | 6 +- compiler/typecheck/TcBinds.hs | 33 +++---- compiler/typecheck/TcClassDcl.hs | 15 ++-- compiler/typecheck/TcEnv.hs | 4 +- compiler/typecheck/TcGenDeriv.hs | 10 +-- compiler/typecheck/TcHsSyn.hs | 31 ++++--- compiler/typecheck/TcInstDcls.hs | 16 ++-- compiler/typecheck/TcPatSyn.hs | 3 + compiler/typecheck/TcSigs.hs | 25 +++--- compiler/typecheck/TcTyClsDecls.hs | 4 +- compiler/typecheck/TcTyDecls.hs | 2 +- 24 files changed, 443 insertions(+), 230 deletions(-) diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 431acddbc9..6f7a457fa5 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -803,16 +803,18 @@ addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do addTickHsValBinds _ = panic "addTickHsValBinds" addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) -addTickHsIPBinds (IPBinds ipbinds dictbinds) = +addTickHsIPBinds (IPBinds dictbinds ipbinds ) = liftM2 IPBinds - (mapM (liftL (addTickIPBind)) ipbinds) (return dictbinds) + (mapM (liftL (addTickIPBind)) ipbinds) +addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x) addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) -addTickIPBind (IPBind nm e) = - liftM2 IPBind +addTickIPBind (IPBind x nm e) = + liftM2 (IPBind x) (return nm) (addTickLHsExpr e) +addTickIPBind (XCIPBind x) = return (XCIPBind x) -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 5028d04de7..ad666a2ce2 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -163,7 +163,7 @@ dsHsBind dflags b@(FunBind { fun_id = L _ fun, fun_matches = matches return (force_var, [core_binds]) } dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_rhs_ty = ty + , pat_ext = NPatBindTc _ ty , pat_ticks = (rhs_tick, var_ticks) }) = do { body_expr <- dsGuarded grhss ty ; checkGuardMatches PatBindGuards grhss @@ -252,6 +252,7 @@ dsAbsBinds dflags tyvars dicts exports ; return (makeCorePair dflags global (isDefaultMethod prags) 0 (core_wrap (Var local))) } + mk_bind (XABExport _) = panic "dsAbsBinds" ; main_binds <- mapM mk_bind exports ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) } @@ -296,6 +297,7 @@ 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 _) = panic "dsAbsBinds" ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) @@ -343,7 +345,8 @@ dsAbsBinds dflags tyvars dicts exports mk_export local = do global <- newSysLocalDs (exprType (mkLams tyvars (mkLams dicts (Var local)))) - return (ABE { abe_poly = global + return (ABE { abe_ext = noExt + , abe_poly = global , abe_mono = local , abe_wrap = WpHole , abe_prags = SpecPrags [] }) diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 30f61e5790..8fa65539b3 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -86,16 +86,18 @@ dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" ------------------------- dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr -dsIPBinds (IPBinds ip_binds ev_binds) body +dsIPBinds (IPBinds ev_binds ip_binds) body = do { ds_binds <- dsTcEvBinds ev_binds ; let inner = mkCoreLets ds_binds body -- The dict bindings may not be in -- dependency order; hence Rec ; foldrM ds_ip_bind inner ip_binds } where - ds_ip_bind (L _ (IPBind ~(Right n) e)) body + ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body = do e' <- dsLExpr e return (Let (NonRec n e') body) + ds_ip_bind (L _ (XCIPBind _)) _ = panic "dsIPBinds" +dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds" ------------------------- -- caller sets location @@ -202,7 +204,8 @@ dsUnliftedBind (FunBind { fun_id = L l fun ; let rhs' = mkOptTickBox tick rhs ; return (bindNonRec fun rhs' body) } -dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body +dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss + , pat_ext = NPatBindTc _ ty }) body = -- let C x# y# = rhs in body -- ==> case rhs of C x# y# -> body do { rhs <- dsGuarded grhss ty diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index afdc1b835d..4d86e1cc83 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -193,11 +193,11 @@ hsSigTvBinders binds get_scoped_tvs :: LSig GhcRn -> [Name] get_scoped_tvs (L _ signature) - | TypeSig _ sig <- signature + | TypeSig _ _ sig <- signature = get_scoped_tvs_from_sig (hswc_body sig) - | ClassOpSig _ _ sig <- signature + | ClassOpSig _ _ _ sig <- signature = get_scoped_tvs_from_sig sig - | PatSynSig _ sig <- signature + | PatSynSig _ _ sig <- signature = get_scoped_tvs_from_sig sig | otherwise = [] @@ -602,7 +602,7 @@ repSafety PlayInterruptible = rep2 interruptibleName [] repSafety PlaySafe = rep2 safeName [] repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -repFixD (L loc (FixitySig names (Fixity _ prec dir))) +repFixD (L loc (FixitySig _ names (Fixity _ prec dir))) = do { MkC prec' <- coreIntLit prec ; let rep_fn = case dir of InfixL -> infixLDName @@ -771,20 +771,21 @@ rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] rep_sigs = concatMapM rep_sig rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms -rep_sig (L loc (PatSynSig nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms -rep_sig (L loc (ClassOpSig is_deflt nms ty)) +rep_sig (L loc (TypeSig _ nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms +rep_sig (L loc (PatSynSig _ nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms +rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms | otherwise = mapM (rep_ty_sig sigDName loc ty) nms rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level -rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc -rep_sig (L loc (SpecSig nm tys ispec)) +rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc +rep_sig (L loc (SpecSig _ nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec loc) tys -rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc +rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc 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 loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc +rep_sig (L _ (XSig _)) = panic "rep_sig" rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name -> DsM (SrcSpan, Core TH.DecQ) @@ -1561,6 +1562,7 @@ 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 _))) = panic "rep_bind: XPatSynBind" rep_bind (L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR" repPatSynD :: Core TH.Name diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index c3eed53fc0..57bb562386 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -153,7 +153,7 @@ cvtDec (TH.ValD pat body ds) ; ds' <- cvtLocalDecs (text "a where clause") ds ; returnJustL $ Hs.ValD $ PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds') - , pat_rhs_ty = placeHolderType, pat_ext = noExt + , pat_ext = noExt , pat_ticks = ([],[]) } } cvtDec (TH.FunD nm cls) @@ -169,7 +169,7 @@ cvtDec (TH.FunD nm cls) cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) } + ; returnJustL $ Hs.SigD (TypeSig noExt [nm'] (mkLHsSigWcType ty')) } cvtDec (TH.InfixD fx nm) -- Fixity signatures are allowed for variables, constructors, and types @@ -177,7 +177,8 @@ cvtDec (TH.InfixD fx nm) -- the RdrName says it's a variable or a constructor. So, just assume -- it's a variable or constructor and proceed. = do { nm' <- vcNameL nm - ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) } + ; returnJustL (Hs.SigD (FixSig noExt + (FixitySig noExt [nm'] (cvtFixity fx)))) } cvtDec (PragmaD prag) = cvtPragmaD prag @@ -358,7 +359,7 @@ cvtDec (TH.StandaloneDerivD ds cxt ty) cvtDec (TH.DefaultSigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') } + ; returnJustL $ Hs.SigD $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')} cvtDec (TH.PatSynD nm args dir pat) = do { nm' <- cNameL nm @@ -366,7 +367,7 @@ cvtDec (TH.PatSynD nm args dir pat) ; dir' <- cvtDir nm' dir ; pat' <- cvtPat pat ; returnJustL $ Hs.ValD $ PatSynBind noExt $ - PSB nm' placeHolderType args' pat' dir' } + PSB noExt nm' placeHolderType args' pat' dir' } where cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2 @@ -384,7 +385,7 @@ cvtDec (TH.PatSynD nm args dir pat) cvtDec (TH.PatSynSigD nm ty) = do { nm' <- cNameL nm ; ty' <- cvtPatSynSigTy ty - ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') } + ; returnJustL $ Hs.SigD $ PatSynSig noExt [nm'] (mkLHsSigType ty') } ---------------- cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs) @@ -651,7 +652,7 @@ cvtPragmaD (InlineP nm inline rm phases) , inl_rule = cvtRuleMatch rm , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ InlineSig nm' ip } + ; returnJustL $ Hs.SigD $ InlineSig noExt nm' ip } cvtPragmaD (SpecialiseP nm ty inline phases) = do { nm' <- vNameL nm @@ -669,12 +670,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases) , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip } + ; returnJustL $ Hs.SigD $ SpecSig noExt nm' [mkLHsSigType ty'] ip } cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtType ty ; returnJustL $ Hs.SigD $ - SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') } + SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') } cvtPragmaD (RuleP nm bndrs lhs rhs phases) = do { let nm' = mkFastString nm @@ -711,7 +712,7 @@ cvtPragmaD (CompleteP cls mty) = do { cls' <- noLoc <$> mapM cNameL cls ; mty' <- traverse tconNameL mty ; returnJustL $ Hs.SigD - $ CompleteMatchSig NoSourceText cls' mty' } + $ CompleteMatchSig noExt NoSourceText cls' mty' } dfltActivation :: TH.Inline -> Activation dfltActivation TH.NoInline = NeverActive diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 164c0a4a1e..d375f6b9ae 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -274,8 +274,7 @@ data HsBindLR idL idR pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] pat_lhs :: LPat idL, pat_rhs :: GRHSs idR (LHsExpr idR), - -- AZ:TODO: put this into TTG extension too - pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs + -- pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs -- bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars] pat_ticks :: ([Tickish Id], [[Tickish Id]]) -- ^ Ticks to put on the rhs, if any, and ticks to put on @@ -331,13 +330,18 @@ data HsBindLR idL idR -- deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR) +data NPatBindTc = NPatBindTc { + pat_fvs :: NameSet, -- ^ Free variables + pat_rhs_ty :: Type -- ^ Type of the GRHSs + } deriving Data + type instance XFunBind (GhcPass pL) GhcPs = PlaceHolder type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables type instance XPatBind GhcPs (GhcPass pR) = PlaceHolder type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables -type instance XPatBind GhcTc (GhcPass pR) = NameSet -- Free variables +type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc type instance XVarBind (GhcPass pL) (GhcPass pR) = PlaceHolder type instance XAbsBinds (GhcPass pL) (GhcPass pR) = PlaceHolder @@ -359,15 +363,20 @@ type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = PlaceHolder -- | Abtraction Bindings Export data ABExport p - -- AZ:TODO: TTG ABExport - = ABE { abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id + = ABE { abe_ext :: XABE p + , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id , abe_mono :: IdP p , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas - } + } + | XABExport (XXABExport p) -- deriving instance (DataId p) => Data (ABExport p) +type instance XABE (GhcPass p) = PlaceHolder +type instance XXABExport (GhcPass p) = PlaceHolder + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@, @@ -377,16 +386,20 @@ data ABExport p -- | Pattern Synonym binding data PatSynBind idL idR - -- AZ:TODO: TTG PatSynBind - = PSB { psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym + = PSB { psb_ext :: XPSB idL idR, + psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars] psb_args :: HsPatSynDetails (Located (IdP idR)), -- ^ Formal parameter names psb_def :: LPat idR, -- ^ Right-hand side psb_dir :: HsPatSynDir idR -- ^ Directionality - } + } + | XPatSynBind (XXPatSynBind idL idR) -- deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR) +type instance XPSB (GhcPass idL) (GhcPass idR) = PlaceHolder +type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = PlaceHolder + {- Note [AbsBinds] ~~~~~~~~~~~~~~~ @@ -686,11 +699,18 @@ pprDeclList ds = pprDeeperList vcat ds emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) emptyLocalBinds = EmptyLocalBinds noExt -isEmptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool -isEmptyLocalBinds (HsValBinds _ ds) = isEmptyValBinds ds -isEmptyLocalBinds (HsIPBinds _ ds) = isEmptyIPBinds ds -isEmptyLocalBinds (EmptyLocalBinds _) = True -isEmptyLocalBinds (XHsLocalBindsLR _) = True +-- AZ:These functions do not seem to be used at all? +isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool +isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds +isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds +isEmptyLocalBindsTc (EmptyLocalBinds _) = True +isEmptyLocalBindsTc (XHsLocalBindsLR _) = True + +isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds +isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds +isEmptyLocalBindsPR (EmptyLocalBinds _) = True +isEmptyLocalBindsPR (XHsLocalBindsLR _) = True eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool eqEmptyLocalBinds (EmptyLocalBinds _) = True @@ -767,8 +787,10 @@ instance (OutputableBndrId p) => Outputable (ABExport p) where = vcat [ ppr gbl <+> text "<=" <+> ppr lcl , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] + ppr (XABExport x) = ppr x -instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR) +instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR, + Outputable (XXPatSynBind idL idR)) => Outputable (PatSynBind idL idR) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) @@ -788,6 +810,7 @@ instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR) 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 @@ -809,15 +832,29 @@ pprTicks pp_no_debug pp_when_debug -- | Haskell Implicit Parameter Bindings data HsIPBinds id - -- AZ:TODO TTG HsIPBinds = IPBinds + (XIPBinds id) [LIPBind id] - TcEvBinds -- Only in typechecker output; binds - -- uses of the implicit parameters + -- TcEvBinds -- Only in typechecker output; binds + -- -- uses of the implicit parameters + | XHsIPBinds (XXHsIPBinds id) -- deriving instance (DataIdLR id id) => Data (HsIPBinds id) -isEmptyIPBinds :: HsIPBinds id -> Bool -isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds +type instance XIPBinds GhcPs = PlaceHolder +type instance XIPBinds GhcRn = PlaceHolder +type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the + -- implicit parameters + + +type instance XXHsIPBinds (GhcPass p) = PlaceHolder + +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) @@ -837,20 +874,28 @@ type LIPBind id = Located (IPBind id) -- For details on above see note [Api annotations] in ApiAnnotation data IPBind id - -- AZ:TTG IPBind. - = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id) + = IPBind + (XIPBind id) + (Either (Located HsIPName) (IdP id)) + (LHsExpr id) + | XCIPBind (XXIPBind id) -- deriving instance (DataIdLR id id) => Data (IPBind id) +type instance XIPBind (GhcPass p) = PlaceHolder +type instance XXIPBind (GhcPass p) = PlaceHolder + instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsIPBinds p) where - ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) + ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) $$ whenPprDebug (ppr ds) + ppr (XHsIPBinds x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where - ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) + 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 (XCIPBind x) = ppr x {- ************************************************************************ @@ -870,7 +915,6 @@ type LSig pass = Located (Sig pass) -- | Signatures and pragmas data Sig pass - -- AZ:TODO: TTG Sig = -- | An ordinary type signature -- -- > f :: Num a => a -> a @@ -888,6 +932,7 @@ data Sig pass -- For details on above see note [Api annotations] in ApiAnnotation TypeSig + (XTypeSig pass) [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah (LHsSigWcType pass) -- RHS of the signature; can have wildcards @@ -900,7 +945,7 @@ data Sig pass -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | PatSynSig [Located (IdP pass)] (LHsSigType pass) + | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass) -- P :: forall a b. Req => Prov => ty -- | A signature for a class method @@ -913,14 +958,14 @@ data Sig pass -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', -- 'ApiAnnotation.AnnDcolon' - | ClassOpSig Bool [Located (IdP pass)] (LHsSigType pass) + | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass) -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record -- the desired Id itself, replete with its name, type -- and IdDetails. Otherwise it's just like a type -- signature: there should be an accompanying binding - | IdSig Id + | IdSig (XIdSig pass) Id -- | An ordinary fixity declaration -- @@ -931,7 +976,7 @@ data Sig pass -- 'ApiAnnotation.AnnVal' -- For details on above see note [Api annotations] in ApiAnnotation - | FixSig (FixitySig pass) + | FixSig (XFixSig pass) (FixitySig pass) -- | An inline pragma -- @@ -944,7 +989,8 @@ data Sig pass -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | InlineSig (Located (IdP pass)) -- Function name + | InlineSig (XInlineSig pass) + (Located (IdP pass)) -- Function name InlinePragma -- Never defaultInlinePragma -- | A specialisation pragma @@ -959,7 +1005,8 @@ data Sig pass -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecSig (Located (IdP pass)) -- Specialise a function or datatype ... + | SpecSig (XSpecSig pass) + (Located (IdP pass)) -- Specialise a function or datatype ... [LHsSigType pass] -- ... to these types InlinePragma -- The pragma on SPECIALISE_INLINE form. -- If it's just defaultInlinePragma, then we said @@ -976,7 +1023,7 @@ data Sig pass -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecInstSig SourceText (LHsSigType pass) + | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) -- Note [Pragma source text] in BasicTypes -- | A minimal complete definition pragma @@ -988,7 +1035,8 @@ data Sig pass -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | MinimalSig SourceText (LBooleanFormula (Located (IdP pass))) + | MinimalSig (XMinimalSig pass) + SourceText (LBooleanFormula (Located (IdP pass))) -- Note [Pragma source text] in BasicTypes -- | A "set cost centre" pragma for declarations @@ -999,7 +1047,8 @@ data Sig pass -- -- > {-# SCC funName "cost_centre_name" #-} - | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes + | SCCFunSig (XSCCFunSig pass) + SourceText -- Note [Pragma source text] in BasicTypes (Located (IdP pass)) -- Function name (Maybe (Located StringLiteral)) -- | A complete match pragma @@ -1009,19 +1058,38 @@ data Sig pass -- Used to inform the pattern match checker about additional -- complete matchings which, for example, arise from pattern -- synonym definitions. - | CompleteMatchSig SourceText + | CompleteMatchSig (XCompleteMatchSig pass) + SourceText (Located [Located (IdP pass)]) (Maybe (Located (IdP pass))) + | XSig (XXSig pass) -- deriving instance (DataIdLR pass pass) => Data (Sig pass) +type instance XTypeSig (GhcPass p) = PlaceHolder +type instance XPatSynSig (GhcPass p) = PlaceHolder +type instance XClassOpSig (GhcPass p) = PlaceHolder +type instance XIdSig (GhcPass p) = PlaceHolder +type instance XFixSig (GhcPass p) = PlaceHolder +type instance XInlineSig (GhcPass p) = PlaceHolder +type instance XSpecSig (GhcPass p) = PlaceHolder +type instance XSpecInstSig (GhcPass p) = PlaceHolder +type instance XMinimalSig (GhcPass p) = PlaceHolder +type instance XSCCFunSig (GhcPass p) = PlaceHolder +type instance XCompleteMatchSig (GhcPass p) = PlaceHolder +type instance XXSig (GhcPass p) = PlaceHolder + -- | Located Fixity Signature type LFixitySig pass = Located (FixitySig pass) -- | Fixity Signature -data FixitySig pass = FixitySig [Located (IdP pass)] Fixity +data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity + | XFixitySig (XXFixitySig pass) -- deriving instance (DataId pass) => Data (FixitySig pass) +type instance XFixitySig (GhcPass p) = PlaceHolder +type instance XXFixitySig (GhcPass p) = PlaceHolder + -- | Type checker Specialisation Pragmas -- -- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer @@ -1102,17 +1170,18 @@ isCompleteMatchSig _ = False hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = text "type signature" hsSigDoc (PatSynSig {}) = text "pattern synonym signature" -hsSigDoc (ClassOpSig is_deflt _ _) +hsSigDoc (ClassOpSig _ is_deflt _ _) | is_deflt = text "default type signature" | otherwise = text "class method signature" hsSigDoc (IdSig {}) = text "id signature" hsSigDoc (SpecSig {}) = text "SPECIALISE pragma" -hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" +hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma" hsSigDoc (FixSig {}) = text "fixity declaration" hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" hsSigDoc (SCCFunSig {}) = text "SCC pragma" hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" +hsSigDoc (XSig {}) = text "XSIG TTG extension" {- Check if signatures overlap; this is used when checking for duplicate @@ -1124,41 +1193,43 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where ppr sig = ppr_sig sig ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc -ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (ClassOpSig is_deflt vars ty) +ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (ClassOpSig _ is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) -ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec })) +ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) +ppr_sig (FixSig _ fix_sig) = ppr fix_sig +ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) (interpp'SP ty) inl) where pragmaSrc = case spec of NoUserInline -> "{-# SPECIALISE" _ -> "{-# SPECIALISE_INLINE" -ppr_sig (InlineSig var inl) +ppr_sig (InlineSig _ var inl) = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl <+> pprPrefixOcc (unLoc var)) -ppr_sig (SpecInstSig src ty) +ppr_sig (SpecInstSig _ src ty) = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty) -ppr_sig (MinimalSig src bf) +ppr_sig (MinimalSig _ src bf) = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) -ppr_sig (PatSynSig names sig_ty) +ppr_sig (PatSynSig _ names sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) -ppr_sig (SCCFunSig src fn mlabel) +ppr_sig (SCCFunSig _ src fn mlabel) = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel ) -ppr_sig (CompleteMatchSig src cs mty) +ppr_sig (CompleteMatchSig _ src cs mty) = pragSrcBrackets src "{-# COMPLETE" ((hsep (punctuate comma (map ppr (unLoc cs)))) <+> opt_sig) where opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty +ppr_sig (XSig x) = ppr x instance OutputableBndrId pass => Outputable (FixitySig pass) where - ppr (FixitySig names fixity) = sep [ppr fixity, pprops] + 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/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index b5ffdfbe28..cc9edbf7ee 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -142,6 +142,80 @@ type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = , c (XXHsBindsLR x x') ) +-- ABExport type families +type family XABE x +type family XXABExport x + +type ForallXABExport (c :: * -> Constraint) (x :: *) = + ( c (XABE x) + , c (XXABExport x) + ) + +-- PatSynBind type families +type family XPSB x x' +type family XXPatSynBind x x' + +type ForallXPatSynBind (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XPSB x x') + , c (XXPatSynBind x x') + ) + +-- HsIPBinds type families +type family XIPBinds x +type family XXHsIPBinds x + +type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) = + ( c (XIPBinds x) + , c (XXHsIPBinds x) + ) + +-- IPBind type families +type family XIPBind x +type family XXIPBind x + +type ForallXIPBind (c :: * -> Constraint) (x :: *) = + ( c (XIPBind x) + , c (XXIPBind x) + ) + +-- Sig type families +type family XTypeSig x +type family XPatSynSig x +type family XClassOpSig x +type family XIdSig x +type family XFixSig x +type family XInlineSig x +type family XSpecSig x +type family XSpecInstSig x +type family XMinimalSig x +type family XSCCFunSig x +type family XCompleteMatchSig x +type family XXSig x + +type ForallXSig (c :: * -> Constraint) (x :: *) = + ( c (XTypeSig x) + , c (XPatSynSig x) + , c (XClassOpSig x) + , c (XIdSig x) + , c (XFixSig x) + , c (XInlineSig x) + , c (XSpecSig x) + , c (XSpecInstSig x) + , c (XMinimalSig x) + , c (XSCCFunSig x) + , c (XCompleteMatchSig x) + , c (XXSig x) + ) + +-- FixitySig type families +type family XFixitySig x +type family XXFixitySig x + +type ForallXFixitySig (c :: * -> Constraint) (x :: *) = + ( c (XFixitySig x) + , c (XXFixitySig x) + ) + -- ===================================================================== -- Type families for the HsDecls extension points @@ -604,6 +678,15 @@ type OutputableX p = , Outputable (XXType p) + , Outputable (XXABExport p) + + , Outputable (XIPBinds p) + , Outputable (XXHsIPBinds p) + , Outputable (XXIPBind p) + , Outputable (XXIPBind GhcRn) + , Outputable (XXSig p) + , Outputable (XXFixitySig p) + , Outputable (XExprWithTySig p) , Outputable (XExprWithTySig GhcRn) @@ -640,12 +723,17 @@ type DataId p = , ForallXFieldOcc Data p , ForallXAmbiguousFieldOcc Data p - , ForallXExpr Data p - , ForallXTupArg Data p - , ForallXSplice Data p - , ForallXBracket Data p - , ForallXCmdTop Data p - , ForallXCmd Data p + , ForallXExpr Data p + , ForallXTupArg Data p + , ForallXSplice Data p + , ForallXBracket Data p + , ForallXCmdTop Data p + , ForallXCmd Data p + , ForallXABExport Data p + , ForallXHsIPBinds Data p + , ForallXIPBind Data p + , ForallXSig Data p + , ForallXFixitySig Data p , Data (NameOrRdrName (IdP p)) @@ -682,9 +770,15 @@ type DataIdLR pL pR = , ForallXHsBindsLR Data pL pL , ForallXHsBindsLR Data pR pR - , ForallXParStmtBlock Data pL pR - , ForallXParStmtBlock Data pL pL - , ForallXParStmtBlock Data pR pR + , ForallXPatSynBind Data pL pR + , ForallXPatSynBind Data pL pL + , ForallXPatSynBind Data pR pR + -- , ForallXPatSynBind Data GhcPs GhcRn + -- , ForallXPatSynBind Data GhcRn GhcRn + + , ForallXParStmtBlock Data pL pR + , ForallXParStmtBlock Data pL pL + , ForallXParStmtBlock Data pR pR , ForallXParStmtBlock Data GhcRn GhcRn ) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index cbd1c2cc48..56ec8d5f97 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -616,8 +616,8 @@ mkHsSigEnv get_info sigs -- of which use this function where (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs - is_gen_dm_sig (L _ (ClassOpSig True _ _)) = True - is_gen_dm_sig _ = False + is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True + is_gen_dm_sig _ = False mk_pairs :: [LSig GhcRn] -> [(Name, a)] mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs @@ -630,8 +630,9 @@ mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] mkClassOpSigs sigs = map fiddle sigs where - fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty)) - fiddle sig = sig + fiddle (L loc (TypeSig _ nms ty)) + = L loc (ClassOpSig noExt False nms (dropWildCards ty)) + fiddle sig = sig typeToLHsType :: Type -> LHsType GhcPs -- ^ Converting a Type to an HsType RdrName @@ -815,7 +816,8 @@ mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs mkPatSynBind name details lpat dir = PatSynBind noExt psb where - psb = PSB{ psb_id = name + psb = PSB{ psb_ext = noExt + , psb_id = name , psb_args = details , psb_def = lpat , psb_dir = dir @@ -990,6 +992,7 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc | omitPatSyn = acc | otherwise = ps : acc +collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc collect_bind _ (XHsBindsLR _) acc = acc collectMethodBinders :: LHsBindsLR GhcPs idR -> [Located RdrName] @@ -1135,7 +1138,8 @@ hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name , tcdSigs = sigs, tcdATs = ats })) = (L loc cls_name : [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ - [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ] + [ L mem_loc mem_name | L mem_loc (ClassOpSig _ False ns _) <- sigs + , L _ mem_name <- ns ] , []) hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })) = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 45835940b9..e3a05724b2 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1449,7 +1449,7 @@ where_decls :: { Located ([AddAnn] pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtypedoc - {% ams (sLL $1 $> $ PatSynSig (unLoc $2) (mkLHsSigType $4)) + {% ams (sLL $1 $> $ PatSynSig noExt (unLoc $2) (mkLHsSigType $4)) [mj AnnPattern $1, mu AnnDcolon $3] } ----------------------------------------------------------------------------- @@ -1466,7 +1466,7 @@ decl_cls : at_decl_cls { $1 } {% do { v <- checkValSigLhs $2 ; let err = text "in default signature" <> colon <+> quotes (ppr $2) - ; ams (sLL $1 $> $ SigD $ ClassOpSig True [v] $ mkLHsSigType $4) + ; ams (sLL $1 $> $ SigD $ ClassOpSig noExt True [v] $ mkLHsSigType $4) [mj AnnDefault $1,mu AnnDcolon $3] } } decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) } -- Reversed @@ -1575,12 +1575,10 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } ,sL1 $1 $ HsValBinds noExt val_binds)) } } | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] - ,sL1 $2 $ HsIPBinds noExt (IPBinds (reverse $ unLoc $2) - emptyTcEvBinds)) } + ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) } | vocurly dbinds close { L (getLoc $2) ([] - ,sL1 $2 $ HsIPBinds noExt (IPBinds (reverse $ unLoc $2) - emptyTcEvBinds)) } + ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) } wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } @@ -2283,7 +2281,7 @@ decl_no_th :: { LHsDecl GhcPs } case r of { (FunBind _ n _ _ _) -> ams (L l ()) [mj AnnFunId n] >> return () ; - (PatBind _ (L lh _lhs) _rhs _ _) -> + (PatBind _ (L lh _lhs) _rhs _) -> ams (L lh ()) [] >> return () } ; _ <- ams (L l ()) (ann ++ fst (unLoc $3) ++ [mj AnnBang $1]) ; @@ -2297,7 +2295,7 @@ decl_no_th :: { LHsDecl GhcPs } case r of { (FunBind _ n _ _ _) -> ams (L l ()) (mj AnnFunId n:(fst $2)) >> return () ; - (PatBind _ (L lh _lhs) _rhs _ _) -> + (PatBind _ (L lh _lhs) _rhs _) -> ams (L lh ()) (fst $2) >> return () } ; _ <- ams (L l ()) (ann ++ (fst $ unLoc $3)); return $! (sL l $ ValD r) } } @@ -2336,10 +2334,10 @@ sigdecl :: { LHsDecl GhcPs } {% do v <- checkValSigLhs $1 ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2] ; return (sLL $1 $> $ SigD $ - TypeSig [v] (mkLHsSigWcType $3)) } + TypeSig noExt [v] (mkLHsSigWcType $3)) } | var ',' sig_vars '::' sigtypedoc - {% do { let sig = TypeSig ($1 : reverse (unLoc $3)) + {% do { let sig = TypeSig noExt ($1 : reverse (unLoc $3)) (mkLHsSigWcType $5) ; addAnnotation (gl $1) AnnComma (gl $2) ; ams ( sLL $1 $> $ SigD sig ) @@ -2347,7 +2345,7 @@ sigdecl :: { LHsDecl GhcPs } | infix prec ops {% ams (sLL $1 $> $ SigD - (FixSig (FixitySig (fromOL $ unLoc $3) + (FixSig noExt (FixitySig noExt (fromOL $ unLoc $3) (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) [mj AnnInfix $1,mj AnnVal $2] } @@ -2357,47 +2355,47 @@ sigdecl :: { LHsDecl GhcPs } {% let (dcolon, tc) = $3 in ams (sLL $1 $> - (SigD (CompleteMatchSig (getCOMPLETE_PRAGs $1) $2 tc))) + (SigD (CompleteMatchSig noExt (getCOMPLETE_PRAGs $1) $2 tc))) ([ mo $1 ] ++ dcolon ++ [mc $4]) } -- This rule is for both INLINE and INLINABLE pragmas | '{-# INLINE' activation qvar '#-}' - {% ams ((sLL $1 $> $ SigD (InlineSig $3 + {% ams ((sLL $1 $> $ SigD (InlineSig noExt $3 (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1) (snd $2))))) ((mo $1:fst $2) ++ [mc $4]) } | '{-# SCC' qvar '#-}' - {% ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 Nothing))) + {% ams (sLL $1 $> (SigD (SCCFunSig noExt (getSCC_PRAGs $1) $2 Nothing))) [mo $1, mc $3] } | '{-# SCC' qvar STRING '#-}' {% do { scc <- getSCC $3 ; let str_lit = StringLiteral (getSTRINGs $3) scc - ; ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) + ; ams (sLL $1 $> (SigD (SCCFunSig noExt (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) [mo $1, mc $4] } } | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' {% ams ( let inl_prag = mkInlinePragma (getSPEC_PRAGs $1) (NoUserInline, FunLike) (snd $2) - in sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag)) + in sLL $1 $> $ SigD (SpecSig noExt $3 (fromOL $5) inl_prag)) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - {% ams (sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) + {% ams (sLL $1 $> $ SigD (SpecSig noExt $3 (fromOL $5) (mkInlinePragma (getSPEC_INLINE_PRAGs $1) (getSPEC_INLINE $1) (snd $2)))) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) } | '{-# SPECIALISE' 'instance' inst_type '#-}' {% ams (sLL $1 $> - $ SigD (SpecInstSig (getSPEC_PRAGs $1) $3)) + $ SigD (SpecInstSig noExt (getSPEC_PRAGs $1) $3)) [mo $1,mj AnnInstance $2,mc $4] } -- A minimal complete definition | '{-# MINIMAL' name_boolformula_opt '#-}' - {% ams (sLL $1 $> $ SigD (MinimalSig (getMINIMAL_PRAGs $1) $2)) + {% ams (sLL $1 $> $ SigD (MinimalSig noExt (getMINIMAL_PRAGs $1) $2)) [mo $1,mc $3] } activation :: { ([AddAnn],Maybe Activation) } @@ -3027,7 +3025,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- | {- empty -} { [] } dbind :: { LIPBind GhcPs } -dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind (Left $1) $3)) +dbind : ipvar '=' exp {% ams (sLL $1 $> (IPBind noExt (Left $1) $3)) [mj AnnEqual $2] } ipvar :: { Located HsIPName } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index f5278fc9fd..13d582cf4c 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -563,7 +563,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = where fromDecl (L loc decl@(ValD (PatBind _ pat@(L _ (ConPatIn ln@(L _ name) details)) - rhs _ _))) = + rhs _))) = do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl ; match <- case details of @@ -1105,7 +1105,7 @@ checkPatBind :: SDoc -> P ([AddAnn],HsBind GhcPs) checkPatBind msg lhs (L _ (_,grhss)) = do { lhs <- checkPattern msg lhs - ; return ([],PatBind noExt lhs grhss placeHolderType + ; return ([],PatBind noExt lhs grhss ([],[])) } checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 4b4aad7c00..4ce3a58539 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -32,7 +32,6 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn import TcRnMonad -import TcEvidence ( emptyTcEvBinds ) import RnTypes import RnPat import RnNames @@ -218,14 +217,16 @@ rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen" rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) -rnIPBinds (IPBinds ip_binds _no_dict_binds) = do +rnIPBinds (IPBinds _ ip_binds ) = do (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds - return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s) + return (IPBinds noExt ip_binds', plusFVs fvs_s) +rnIPBinds (XHsIPBinds _) = panic "rnIPBinds" rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) -rnIPBind (IPBind ~(Left n) expr) = do +rnIPBind (IPBind _ ~(Left n) expr) = do (expr',fvExpr) <- rnLExpr expr - return (IPBind (Left n) expr', fvExpr) + return (IPBind noExt (Left n) expr', fvExpr) +rnIPBind (XCIPBind _) = panic "rnIPBind" {- ************************************************************************ @@ -340,8 +341,8 @@ rnLocalValBindsAndThen -> RnM (result, FreeVars) rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside = do { -- (A) Create the local fixity environment - new_fixities <- makeMiniFixityEnv [L loc sig - | L loc (FixSig sig) <- sigs] + new_fixities <- makeMiniFixityEnv [ L loc sig + | L loc (FixSig _ sig) <- sigs] -- (B) Rename the LHSes ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds @@ -421,13 +422,13 @@ rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) | isTopRecNameMaker name_maker = do { addLocM checkConName rdrname ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already - ; return (PatSynBind x psb{ psb_id = name }) } + ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) } | otherwise -- Pattern synonym, not at top level = do { addErr localPatternSynonymErr -- Complain, but make up a fake -- name so that we can carry on ; name <- applyNameMaker name_maker rdrname - ; return (PatSynBind x psb{ psb_id = name }) } + ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) } where localPatternSynonymErr :: SDoc localPatternSynonymErr @@ -464,7 +465,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan bndrs = collectPatBinders pat bind' = bind { pat_rhs = grhss' - , pat_rhs_ty = placeHolderType, pat_ext = fvs' } + , pat_ext = fvs' } ok_nobind_pat = -- See Note [Pattern bindings that bind no variables] @@ -593,11 +594,11 @@ mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name]) -- Returns (binders, scoped tvs for those binders) - get_scoped_tvs (L _ (ClassOpSig _ names sig_ty)) + get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty)) = Just (names, hsScopedTvs sig_ty) - get_scoped_tvs (L _ (TypeSig names sig_ty)) + get_scoped_tvs (L _ (TypeSig _ names sig_ty)) = Just (names, hsWcScopedTvs sig_ty) - get_scoped_tvs (L _ (PatSynSig names sig_ty)) + get_scoped_tvs (L _ (PatSynSig _ names sig_ty)) = Just (names, hsScopedTvs sig_ty) get_scoped_tvs _ = Nothing @@ -612,9 +613,10 @@ makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls where - add_one_sig env (L loc (FixitySig names fixity)) = + 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 _)) = panic "makeMiniFixityEnv" add_one env (loc, name_loc, name,fixity) = do { -- this fixity decl is a duplicate iff @@ -703,7 +705,8 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name -- As well as dependency analysis, we need these for the -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - bind' = bind{ psb_args = details' + bind' = bind{ psb_ext = noExt + , psb_args = details' , psb_def = pat' , psb_dir = dir' , psb_fvs = fvs' } @@ -725,6 +728,8 @@ 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 _) = panic "rnPatSynBind" + {- Note [Renaming pattern synonym variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -941,41 +946,41 @@ renameSigs ctxt sigs -- Doesn't seem worth much trouble to sort this. renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) -renameSig _ (IdSig x) - = return (IdSig x, emptyFVs) -- Actually this never occurs +renameSig _ (IdSig _ x) + = return (IdSig noExt x, emptyFVs) -- Actually this never occurs -renameSig ctxt sig@(TypeSig vs ty) +renameSig ctxt sig@(TypeSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs) ; (new_ty, fvs) <- rnHsSigWcType doc ty - ; return (TypeSig new_vs new_ty, fvs) } + ; return (TypeSig noExt new_vs new_ty, fvs) } -renameSig ctxt sig@(ClassOpSig is_deflt vs ty) +renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures ; when (is_deflt && not defaultSigs_on) $ addErr (defaultSigErr sig) ; new_v <- mapM (lookupSigOccRn ctxt sig) vs ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty - ; return (ClassOpSig is_deflt new_v new_ty, fvs) } + ; return (ClassOpSig noExt is_deflt new_v new_ty, fvs) } where (v1:_) = vs ty_ctxt = GenericCtx (text "a class method signature for" <+> quotes (ppr v1)) -renameSig _ (SpecInstSig src ty) +renameSig _ (SpecInstSig _ src ty) = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty - ; return (SpecInstSig src new_ty,fvs) } + ; return (SpecInstSig noExt src new_ty,fvs) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) -- we use lookupOccRn. If there's both an imported and a local 'f' -- then the SPECIALISE pragma is ambiguous, unlike all other signatures -renameSig ctxt sig@(SpecSig v tys inl) +renameSig ctxt sig@(SpecSig _ v tys inl) = do { new_v <- case ctxt of TopSigCtxt {} -> lookupLocatedOccRn v _ -> lookupSigOccRn ctxt sig v ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys - ; return (SpecSig new_v new_ty inl, fvs) } + ; return (SpecSig noExt new_v new_ty inl, fvs) } where ty_ctxt = GenericCtx (text "a SPECIALISE signature for" <+> quotes (ppr v)) @@ -983,33 +988,33 @@ renameSig ctxt sig@(SpecSig v tys inl) = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } -renameSig ctxt sig@(InlineSig v s) +renameSig ctxt sig@(InlineSig _ v s) = do { new_v <- lookupSigOccRn ctxt sig v - ; return (InlineSig new_v s, emptyFVs) } + ; return (InlineSig noExt new_v s, emptyFVs) } -renameSig ctxt (FixSig fsig) +renameSig ctxt (FixSig _ fsig) = do { new_fsig <- rnSrcFixityDecl ctxt fsig - ; return (FixSig new_fsig, emptyFVs) } + ; return (FixSig noExt new_fsig, emptyFVs) } -renameSig ctxt sig@(MinimalSig s (L l bf)) +renameSig ctxt sig@(MinimalSig _ s (L l bf)) = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf - return (MinimalSig s (L l new_bf), emptyFVs) + return (MinimalSig noExt s (L l new_bf), emptyFVs) -renameSig ctxt sig@(PatSynSig vs ty) +renameSig ctxt sig@(PatSynSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs ; (ty', fvs) <- rnHsSigType ty_ctxt ty - ; return (PatSynSig new_vs ty', fvs) } + ; return (PatSynSig noExt new_vs ty', fvs) } where ty_ctxt = GenericCtx (text "a pattern synonym signature for" <+> ppr_sig_bndrs vs) -renameSig ctxt sig@(SCCFunSig st v s) +renameSig ctxt sig@(SCCFunSig _ st v s) = do { new_v <- lookupSigOccRn ctxt sig v - ; return (SCCFunSig st new_v s, emptyFVs) } + ; return (SCCFunSig noExt st new_v s, emptyFVs) } -- COMPLETE Sigs can refer to imported IDs which is why we use -- lookupLocatedOccRn rather than lookupSigOccRn -renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty) +renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) = do new_bf <- traverse lookupLocatedOccRn bf new_mty <- traverse lookupLocatedOccRn mty @@ -1018,7 +1023,7 @@ renameSig _ctxt sig@(CompleteMatchSig s (L l bf) mty) -- Why 'any'? See Note [Orphan COMPLETE pragmas] addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError - return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs) + return (CompleteMatchSig noExt s (L l new_bf) new_mty, emptyFVs) where orphanError :: SDoc orphanError = @@ -1026,6 +1031,8 @@ 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 _) = panic "renameSig" + {- Note [Orphan COMPLETE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1092,6 +1099,8 @@ okHsSig ctxt (L _ sig) (CompleteMatchSig {}, TopSigCtxt {} ) -> True (CompleteMatchSig {}, _) -> False + (XSig _, _) -> panic "okHsSig" + ------------------- findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)] -- Check for duplicates on RdrName version, @@ -1105,20 +1114,20 @@ findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)] findDupSigs sigs = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) where - expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig) - expand_sig sig@(InlineSig n _) = [(n,sig)] - expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns] - expand_sig sig@(ClassOpSig _ ns _) = [(n,sig) | n <- ns] - expand_sig sig@(PatSynSig ns _ ) = [(n,sig) | n <- ns] - expand_sig sig@(SCCFunSig _ n _) = [(n,sig)] + expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig) + expand_sig sig@(InlineSig _ n _) = [(n,sig)] + expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] + expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns] + expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns] + expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)] expand_sig _ = [] matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 mtch (FixSig {}) (FixSig {}) = True mtch (InlineSig {}) (InlineSig {}) = True mtch (TypeSig {}) (TypeSig {}) = True - mtch (ClassOpSig d1 _ _) (ClassOpSig d2 _ _) = d1 == d2 - mtch (PatSynSig _ _) (PatSynSig _ _) = True + mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2 + mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True mtch (SCCFunSig{}) (SCCFunSig{}) = True mtch _ _ = False @@ -1240,9 +1249,10 @@ rnSrcFixityDecl sig_ctxt = rn_decl -- for con-like things; hence returning a list -- If neither are in scope, report an error; otherwise -- return a fixity sig for each (slightly odd) - rn_decl (FixitySig fnames fixity) + rn_decl (FixitySig _ fnames fixity) = do names <- concatMapM lookup_one fnames - return (FixitySig names fixity) + return (FixitySig noExt names fixity) + rn_decl (XFixitySig _) = panic "rnSrcFixityDecl" lookup_one :: Located RdrName -> RnM [Located Name] lookup_one (L name_loc rdr_name) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index dec5cb1b35..4fe4102891 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -1100,9 +1100,9 @@ collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of (L _ (LetStmt (L _ (HsValBinds _ (ValBinds _ _ sigs))))) -> - foldr (\ sig -> \ acc -> case sig of - (L loc (FixSig s)) -> (L loc s) : acc - _ -> acc) acc sigs + foldr (\ sig -> \ acc -> case sig of + (L loc (FixSig _ s)) -> (L loc s) : acc + _ -> acc) acc sigs _ -> acc) [] l -- left-hand sides diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 0f6f3a1327..5458469c44 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -667,7 +667,7 @@ getLocalNonValBinders fixity_env -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders hs_boot_sig_bndrs = [ L decl_loc (unLoc n) - | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns] + | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] -- the SrcSpan attached to the input should be the span of the -- declaration, not just the name diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 6881575c0b..07dcff2a04 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -1571,7 +1571,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs + ; let sig_rdr_names_w_locs = [op |L _ (ClassOpSig _ False ops _) <- sigs , op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only @@ -2105,13 +2105,13 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds -- Class declarations: pull out the fixity signatures to the top add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds | isClassDecl d - = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in + = let fsigs = [ L l f | L l (FixSig _ f) <- tcdSigs d ] in addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds | otherwise = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds -- Signatures: fixity sigs go a different place than all others -add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds +add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig _ f)) ds = addl (gp {hs_fixds = L l f : ts}) ds add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds = addl (gp {hs_valds = add_sig (L l d) ts}) ds diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 893b18b51c..4d2e51f728 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -235,7 +235,7 @@ tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch] tcCompleteSigs sigs = let doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch) - doOne c@(CompleteMatchSig _ lns mtc) + doOne c@(CompleteMatchSig _ _ lns mtc) = fmap Just $ do addErrCtxt (text "In" <+> ppr c) $ case mtc of @@ -308,7 +308,7 @@ tcCompleteSigs sigs = tcRecSelBinds :: HsValBinds GhcRn -> TcM TcGblEnv tcRecSelBinds (XValBindsLR (NValBinds binds sigs)) - = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ + = tcExtendGlobalValEnv [sel_id | L _ (IdSig _ sel_id) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ tcValBinds TopLevel binds sigs getGblEnv ; let tcg_env' = tcg_env `addTypecheckedBinds` map snd rec_sel_binds @@ -322,7 +322,7 @@ tcHsBootSigs binds sigs = do { checkTc (null binds) badBootDeclErr ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where - tc_boot_sig (TypeSig lnames hs_ty) = mapM f lnames + tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where f (L _ name) = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty @@ -346,7 +346,7 @@ tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" -tcLocalBinds (HsIPBinds x (IPBinds ip_binds _)) thing_inside +tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside = do { ipClass <- tcLookupClass ipClassName ; (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds @@ -357,28 +357,30 @@ tcLocalBinds (HsIPBinds x (IPBinds ip_binds _)) thing_inside ; (ev_binds, result) <- checkConstraints (IPSkol ips) [] given_ips thing_inside - ; return (HsIPBinds x (IPBinds ip_binds' ev_binds), result) } + ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) } where - ips = [ip | L _ (IPBind (Left (L _ ip)) _) <- ip_binds] + ips = [ip | L _ (IPBind _ (Left (L _ ip)) _) <- ip_binds] -- I wonder if we should do these one at at time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind ipClass (IPBind (Left (L _ ip)) expr) + tc_ip_bind ipClass (IPBind _ (Left (L _ ip)) expr) = do { ty <- newOpenFlexiTyVarTy ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcMonoExpr expr (mkCheckExpType ty) ; let d = toDict ipClass p ty `fmap` expr' - ; return (ip_id, (IPBind (Right ip_id) d)) } - tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind" + ; return (ip_id, (IPBind noExt (Right ip_id) d)) } + tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind" + tc_ip_bind _ (XCIPBind _) = panic "tc_ip_bind" -- Coerces a `t` into a dictionry for `IP "x" t`. -- co : t -> IP "x" t toDict ipClass x ty = mkHsWrap $ mkWpCastR $ wrapIP $ mkClassPred ipClass [x,ty] -tcLocalBinds (XHsLocalBindsLR _) _ = panic "tcLocalBinds" +tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds" +tcLocalBinds (XHsLocalBindsLR _) _ = panic "tcLocalBinds" {- Note [Implicit parameter untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -726,7 +728,8 @@ tcPolyCheck prag_fn , fun_ext = placeHolderNamesTc , fun_tick = tick } - export = ABE { abe_wrap = idHsWrapper + export = ABE { abe_ext = noExt + , abe_wrap = idHsWrapper , abe_poly = poly_id , abe_mono = mono_id , abe_prags = SpecPrags spec_prags } @@ -748,7 +751,7 @@ tcPolyCheck _prag_fn sig bind funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [Tickish TcId] funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ] + | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected -- by the renamer , let cc_str @@ -875,7 +878,8 @@ mkExport prag_fn insoluble qtvs theta ; when warn_missing_sigs $ localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig - ; return (ABE { abe_wrap = wrap + ; return (ABE { abe_ext = noExt + , abe_wrap = wrap -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty) , abe_poly = poly_id , abe_mono = mono_id @@ -1512,8 +1516,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty) ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss pat_ty ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' - , pat_rhs_ty = pat_ty - , pat_ext = placeHolderNamesTc + , pat_ext = NPatBindTc placeHolderNamesTc pat_ty , pat_ticks = ([],[]) } )} tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 70f3f9e8f0..496bd1597b 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -139,8 +139,8 @@ tcClassSigs clas sigs def_methods ; traceTc "tcClassSigs 2" (ppr clas) ; return op_info } where - vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs] - gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig True nm ty) <- sigs] + vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs] + gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ True nm ty) <- sigs] dm_bind_names :: [Name] -- These ones have a value binding in the class decl dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] @@ -280,7 +280,8 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn tcPolyCheck no_prag_fn local_dm_sig (L bind_loc lm_bind) - ; let export = ABE { abe_poly = global_dm_id + ; let export = ABE { abe_ext = noExt + , abe_poly = global_dm_id , abe_mono = local_dm_id , abe_wrap = idHsWrapper , abe_prags = IsDefaultMethod } @@ -352,8 +353,8 @@ mkHsSigFun sigs = lookupNameEnv env env = mkHsSigEnv get_classop_sig sigs get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn) - get_classop_sig (L _ (ClassOpSig _ ns hs_ty)) = Just (ns, hs_ty) - get_classop_sig _ = Nothing + get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty) + get_classop_sig _ = Nothing --------------------------- findMethodBind :: Name -- Selector @@ -378,8 +379,8 @@ findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef findMinimalDef = firstJusts . map toMinimalDef where toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef - toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf) - toMinimalDef _ = Nothing + toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf) + toMinimalDef _ = Nothing {- Note [Polymorphic methods] diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 9f48fe0523..790708b4c9 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -655,8 +655,8 @@ getTypeSigNames sigs get_type_sig :: LSig GhcRn -> NameSet -> NameSet get_type_sig sig ns = case sig of - L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names) - L _ (PatSynSig names _) -> extendNameSetList ns (map unLoc names) + L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names) + L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names) _ -> ns diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 383b580aa5..88b697b72a 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1328,7 +1328,7 @@ gen_data dflags data_type_name constr_names loc rep_tc genDataTyCon :: DerivStuff genDataTyCon -- $dT = DerivHsBind (mkHsVarBind loc data_type_name rhs, - L loc (TypeSig [L loc data_type_name] sig_ty)) + L loc (TypeSig noExt [L loc data_type_name] sig_ty)) sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) rhs = nlHsVar mkDataType_RDR @@ -1338,7 +1338,7 @@ gen_data dflags data_type_name constr_names loc rep_tc genDataDataCon :: DataCon -> RdrName -> DerivStuff genDataDataCon dc constr_name -- $cT1 etc = DerivHsBind (mkHsVarBind loc constr_name rhs, - L loc (TypeSig [L loc constr_name] sig_ty)) + L loc (TypeSig noExt [L loc constr_name] sig_ty)) where sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) rhs = nlHsApps mkConstr_RDR constr_args @@ -1759,7 +1759,7 @@ genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpec dflags loc (DerivCon2Tag tycon) = (mkFunBindSE 0 loc rdr_name eqns, - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig noExt [L loc rdr_name] sig_ty)) where rdr_name = con2tag_RDR dflags tycon @@ -1785,7 +1785,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon) = (mkFunBindSE 0 loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig noExt [L loc rdr_name] sig_ty)) where sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ @@ -1795,7 +1795,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon) genAuxBindSpec dflags loc (DerivMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig noExt [L loc rdr_name] sig_ty)) where rdr_name = maxtag_RDR dflags tycon sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy))) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 1ce29ea551..789725f060 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -418,18 +418,22 @@ zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) ; (env2, bs') <- go env1 bs ; return (env2, (r,b'):bs') } -zonkLocalBinds env (HsIPBinds x (IPBinds binds dict_binds)) = do +zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do new_binds <- mapM (wrapLocM zonk_ip_bind) binds let - env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds] + env1 = extendIdZonkEnvRec env [ n + | L _ (IPBind _ (Right n) _) <- new_binds] (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds - return (env2, HsIPBinds x (IPBinds new_binds new_dict_binds)) + return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) where - zonk_ip_bind (IPBind n e) + zonk_ip_bind (IPBind x n e) = do n' <- mapIPNameTc (zonkIdBndr env) n e' <- zonkLExpr env e - return (IPBind n' e') + return (IPBind x n' e') + zonk_ip_bind (XCIPBind _) = panic "zonkLocalBinds : XCIPBind" +zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _)) + = panic "zonkLocalBinds" -- Not in typechecker output zonkLocalBinds _ (XHsLocalBindsLR _) = panic "zonkLocalBinds" -- Not in typechecker output @@ -449,11 +453,13 @@ zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc) zonk_lbind env = wrapLocM (zonk_bind env) zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc) -zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) +zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_ext = NPatBindTc fvs ty}) = do { (_env, new_pat) <- zonkPat env pat -- Env already extended ; new_grhss <- zonkGRHSs env zonkLExpr grhss ; new_ty <- zonkTcTypeToType env ty - ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } + ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss + , pat_ext = NPatBindTc fvs new_ty }) } zonk_bind env (VarBind { var_ext = x , var_id = var, var_rhs = expr, var_inline = inl }) @@ -510,17 +516,20 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs | otherwise = zonk_lbind env lbind -- The normal case - zonk_export env (ABE{ abe_wrap = wrap + zonk_export env (ABE{ abe_ext = x + , abe_wrap = wrap , abe_poly = poly_id , abe_mono = mono_id , abe_prags = prags }) = do new_poly_id <- zonkIdBndr env poly_id (_, new_wrap) <- zonkCoFn env wrap new_prags <- zonkSpecPrags env prags - return (ABE{ abe_wrap = new_wrap + return (ABE{ abe_ext = x + , abe_wrap = new_wrap , abe_poly = new_poly_id , abe_mono = zonkIdOcc env mono_id , abe_prags = new_prags }) + zonk_export _ (XABExport _) = panic "zonk_bind: XABExport" zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id , psb_args = details @@ -535,7 +544,9 @@ zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id , psb_args = details' , psb_def = lpat' , psb_dir = dir' } } -zonk_bind _ (XHsBindsLR _) = panic "zonk_bind" + +zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind" +zonk_bind _ (XHsBindsLR _) = panic "zonk_bind" zonkPatSynDetails :: ZonkEnv -> HsPatSynDetails (Located TcId) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 8e201045c1..1a55d4c51c 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -890,7 +890,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Newtype dfuns just inline unconditionally, -- so don't attempt to specialise them - export = ABE { abe_wrap = idHsWrapper + export = ABE { abe_ext = noExt + , abe_wrap = idHsWrapper , abe_poly = dfun_id_w_prags , abe_mono = self_dict , abe_prags = dfun_spec_prags } @@ -1040,7 +1041,8 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id (EvExpr sc_ev_tm) ; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred) sc_top_id = mkLocalId sc_top_name sc_top_ty - export = ABE { abe_wrap = idHsWrapper + export = ABE { abe_ext = noExt + , abe_wrap = idHsWrapper , abe_poly = sc_top_id , abe_mono = sc_ev_id , abe_prags = noSpecPrags } @@ -1382,7 +1384,8 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys ; spec_prags <- tcSpecPrags global_meth_id prags ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags - export = ABE { abe_poly = global_meth_id + export = ABE { abe_ext = noExt + , abe_poly = global_meth_id , abe_mono = local_meth_id , abe_wrap = idHsWrapper , abe_prags = specs } @@ -1431,7 +1434,8 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind - ; let export = ABE { abe_poly = local_meth_id + ; let export = ABE { abe_ext = noExt + , abe_poly = local_meth_id , abe_mono = inner_id , abe_wrap = hs_wrap , abe_prags = noSpecPrags } @@ -1583,7 +1587,7 @@ mkDefMethBind clas inst_tys sel_id dm_name ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag - = [noLoc (InlineSig fn inline_prag)] + = [noLoc (InlineSig noExt fn inline_prag)] | otherwise = [] -- Copy the inline pragma (if any) from the default method @@ -1806,7 +1810,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) ------------------------------ tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag -tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) +tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty) = addErrCtxt (spec_ctxt prag) $ do { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 7f8187cf78..76eb1bd9b4 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -119,6 +119,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, , mkTyVarTys ex_tvs, prov_theta, map evId filtered_prov_dicts) (map nlHsVar args, map idType args) pat_ty rec_fields } +tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl" badUnivTvErr :: [TyVar] -> TyVar -> TcM () -- See Note [Type variables whose kind is captured] @@ -332,6 +333,7 @@ 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 _) _ = panic "tcCheckPatSynDecl" {- [Pattern synonyms and higher rank types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -821,6 +823,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat = 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 _) = panic "tcPatSynBuilderBind" tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType) -- monadic only for failure diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index 62fa83287c..706c10c819 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -180,20 +180,20 @@ tcTySigs hs_sigs ; return (poly_ids, lookupNameEnv env) } tcTySig :: LSig GhcRn -> TcM [TcSigInfo] -tcTySig (L _ (IdSig id)) +tcTySig (L _ (IdSig _ id)) = do { let ctxt = FunSigCtxt (idName id) False -- False: do not report redundant constraints -- The user has no control over the signature! sig = completeSigFromId ctxt id ; return [TcIdSig sig] } -tcTySig (L loc (TypeSig names sig_ty)) +tcTySig (L loc (TypeSig _ names sig_ty)) = setSrcSpan loc $ do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name) | L _ name <- names ] ; return (map TcIdSig sigs) } -tcTySig (L loc (PatSynSig names sig_ty)) +tcTySig (L loc (PatSynSig _ names sig_ty)) = setSrcSpan loc $ do { tpsigs <- sequence [ tcPatSynSig name sig_ty | L _ name <- names ] @@ -477,10 +477,13 @@ mkPragEnv sigs binds prs = mapMaybe get_sig sigs get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) - get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl)) - get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl)) - get_sig (L l (SCCFunSig st lnm@(L _ nm) str)) = Just (nm, L l $ SCCFunSig st lnm str) - get_sig _ = Nothing + get_sig (L l (SpecSig x lnm@(L _ nm) ty inl)) + = Just (nm, L l $ SpecSig x lnm ty (add_arity nm inl)) + get_sig (L l (InlineSig x lnm@(L _ nm) inl)) + = Just (nm, L l $ InlineSig x lnm (add_arity nm inl)) + get_sig (L l (SCCFunSig x st lnm@(L _ nm) str)) + = Just (nm, L l $ SCCFunSig x st lnm str) + get_sig _ = Nothing add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function | Inline <- inl_inline inl_prag @@ -513,7 +516,7 @@ addInlinePrags poly_id prags_for_me | otherwise = return poly_id where - inl_prags = [L loc prag | L loc (InlineSig _ prag) <- prags_for_me] + inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me] warn_multiple_inlines _ [] = return () @@ -665,7 +668,7 @@ tcSpecPrags poly_id prag_sigs -------------- tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] -tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl) +tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) -- See Note [Handling SPECIALISE pragmas] -- -- The Name fun_name in the SpecSig may not be the same as that of the poly_id @@ -721,8 +724,8 @@ tcImpPrags prags else do { pss <- mapAndRecoverM (wrapLocM tcImpSpec) [L loc (name,prag) - | (L loc prag@(SpecSig (L _ name) _ _)) <- prags - , not (nameIsLocalOrFrom this_mod name) ] + | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags + , not (nameIsLocalOrFrom this_mod name) ] ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } where -- Ignore SPECIALISE pragmas for imported things diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 0cfe494fc7..ba1626ca3d 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -656,8 +656,8 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM kc_sig) sigs } where - kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty - kc_sig _ = return () + kc_sig (ClassOpSig _ _ nms op_ty) = kcHsSigType nms op_ty + kc_sig _ = return () kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name , fdInfo = fd_info })) diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 3a06af6b3a..5f2a629883 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -843,7 +843,7 @@ mkRecSelBind (tycon, fl) mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> (LSig GhcRn, (RecFlag, LHsBinds GhcRn)) mkOneRecordSelector all_cons idDetails fl - = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind))) + = (L loc (IdSig noExt sel_id), (NonRecursive, unitBag (L loc sel_bind))) where loc = getSrcSpan sel_name lbl = flLabel fl -- cgit v1.2.1