diff options
42 files changed, 1336 insertions, 635 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 1f84114726..ab04ee472f 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -351,6 +351,7 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do -- 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 @@ -779,13 +780,14 @@ addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders" addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) -addTickHsLocalBinds (HsValBinds binds) = - liftM HsValBinds +addTickHsLocalBinds (HsValBinds x binds) = + liftM (HsValBinds x) (addTickHsValBinds binds) -addTickHsLocalBinds (HsIPBinds binds) = - liftM HsIPBinds +addTickHsLocalBinds (HsIPBinds x binds) = + liftM (HsIPBinds x) (addTickHsIPBinds binds) -addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds +addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) +addTickHsLocalBinds (XHsLocalBindsLR x) = return (XHsLocalBindsLR x) addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) -> TM (HsValBindsLR GhcTc (GhcPass b)) @@ -801,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 3a736a5e6c..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 @@ -192,6 +192,7 @@ 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{}) = panic "dsHsBind: XHsBindsLR" ----------------------- @@ -251,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) } @@ -295,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) @@ -342,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 0eb5c0e376..6f7f66e6a4 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -71,10 +71,11 @@ import Control.Monad -} dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr -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 (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 (L _ (XHsLocalBindsLR _)) _ = panic "dsLocalBinds" ------------------------- -- caller sets location @@ -85,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 @@ -201,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 fd8da266ae..976f3c3d12 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 @@ -613,6 +613,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir))) ; dec <- rep2 rep_fn [prec', name'] ; return (loc,dec) } ; mapM do_one names } +repFixD (L _ (XFixitySig _)) = panic "repFixD" repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) @@ -771,20 +772,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) @@ -1445,13 +1447,13 @@ repSts other = notHandled "Exotic statement" (ppr other) ----------------------------------------------------------- repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ]) -repBinds EmptyLocalBinds +repBinds (EmptyLocalBinds _) = do { core_list <- coreList decQTyConName [] ; return ([], core_list) } -repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b) +repBinds b@(HsIPBinds {}) = notHandled "Implicit parameters" (ppr b) -repBinds (HsValBinds decs) +repBinds (HsValBinds _ decs) = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs } -- No need to worry about detailed scopes within -- the binding group, because we are talking Names @@ -1463,6 +1465,7 @@ repBinds (HsValBinds decs) ; core_list <- coreList decQTyConName (de_loc (sort_by_loc prs)) ; return (ss, core_list) } +repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b) rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are already in the meta-env @@ -1521,11 +1524,11 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) ; return (srcLocSpan (getSrcLoc v), ans) } rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" -rep_bind (L loc (PatSynBind (PSB { psb_id = syn - , psb_fvs = _fvs - , psb_args = args - , psb_def = pat - , psb_dir = dir }))) +rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn + , psb_fvs = _fvs + , psb_args = args + , psb_def = pat + , psb_dir = dir }))) = do { syn' <- lookupLBinder syn ; dir' <- repPatSynDir dir ; ss <- mkGenArgSyms args @@ -1560,6 +1563,9 @@ 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 -> Core TH.PatSynArgsQ -> Core TH.PatSynDirQ @@ -1628,7 +1634,8 @@ repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) repLambda (L _ (Match { m_pats = ps - , m_grhss = GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds) } )) + , m_grhss = GRHSs [L _ (GRHS [] e)] + (L _ (EmptyLocalBinds _)) } )) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index a34990475d..36dc437cd7 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -320,6 +320,7 @@ Library HsLit PlaceHolder HsExtension + HsInstances HsPat HsSyn HsTypes diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 285d2e936e..c63de9ec36 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, bind_fvs = placeHolderNames + , 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,15 +359,15 @@ 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 ; args' <- cvtArgs args ; dir' <- cvtDir nm' dir ; pat' <- cvtPat pat - ; returnJustL $ Hs.ValD $ PatSynBind $ - PSB nm' placeHolderType args' pat' dir' } + ; returnJustL $ Hs.ValD $ PatSynBind noExt $ + 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 @@ -747,13 +748,13 @@ cvtRuleBndr (TypedRuleVar n ty) cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) cvtLocalDecs doc ds | null ds - = return EmptyLocalBinds + = return (EmptyLocalBinds noExt) | otherwise = do { ds' <- cvtDecs ds ; let (binds, prob_sigs) = partitionWith is_bind ds' ; let (sigs, bads) = partitionWith is_sig prob_sigs ; unless (null bads) (failWith (mkBadDecMsg doc bads)) - ; return (HsValBinds (ValBinds noExt (listToBag binds) sigs)) } + ; return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs)) } cvtClause :: HsMatchContext RdrName -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 5fa0a62687..ea5704c5d2 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -74,7 +74,9 @@ type LHsLocalBinds id = Located (HsLocalBinds id) -- Bindings in a 'let' expression -- or a 'where' clause data HsLocalBindsLR idL idR - = HsValBinds (HsValBindsLR idL idR) + = HsValBinds + (XHsValBinds idL idR) + (HsValBindsLR idL idR) -- ^ Haskell Value Bindings -- There should be no pattern synonyms in the HsValBindsLR @@ -82,15 +84,24 @@ data HsLocalBindsLR idL idR -- The parser accepts them, however, leaving the -- renamer to report them - | HsIPBinds (HsIPBinds idR) + | HsIPBinds + (XHsIPBinds idL idR) + (HsIPBinds idR) -- ^ Haskell Implicit Parameter Bindings - | EmptyLocalBinds + | EmptyLocalBinds (XEmptyLocalBinds idL idR) -- ^ Empty Local Bindings + | XHsLocalBindsLR + (XXHsLocalBindsLR idL idR) + +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = PlaceHolder + type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) -deriving instance (DataIdLR idL idR) => Data (HsLocalBindsLR idL idR) -- | Haskell Value Bindings type HsValBinds id = HsValBindsLR id id @@ -116,8 +127,6 @@ data HsValBindsLR idL idR | XValBindsLR (XXValBindsLR idL idR) -deriving instance (DataIdLR idL idR) => Data (HsValBindsLR idL idR) - -- --------------------------------------------------------------------- -- Deal with ValBindsOut @@ -126,7 +135,6 @@ data NHsValBindsLR idL = NValBinds [(RecFlag, LHsBinds idL)] [LSig GhcRn] -deriving instance (DataIdLR idL idL) => Data (NHsValBindsLR idL) type instance XValBinds (GhcPass pL) (GhcPass pR) = PlaceHolder type instance XXValBindsLR (GhcPass pL) (GhcPass pR) @@ -212,6 +220,11 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation FunBind { + fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains + -- the locally-bound + -- free variables of this defn. + -- See Note [Bind free vars] + fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload @@ -230,12 +243,6 @@ data HsBindLR idL idR -- type Int -> forall a'. a' -> a' -- Notice that the coercion captures the free a'. - bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains - -- the locally-bound - -- free variables of this defn. - -- See Note [Bind free vars] - - fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any } @@ -253,10 +260,9 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation | PatBind { + pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] pat_lhs :: LPat idL, pat_rhs :: GRHSs idR (LHsExpr idR), - 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 -- the bound variables. @@ -267,6 +273,7 @@ data HsBindLR idL idR -- Dictionary binding and suchlike. -- All VarBinds are introduced by the type checker | VarBind { + var_ext :: XVarBind idL idR, var_id :: IdP idL, var_rhs :: LHsExpr idR, -- ^ Located only for consistency var_inline :: Bool -- ^ True <=> inline this binding regardless @@ -275,6 +282,7 @@ data HsBindLR idL idR -- | Abstraction Bindings | AbsBinds { -- Binds abstraction; TRANSLATION + abs_ext :: XAbsBinds idL idR, abs_tvs :: [TyVar], abs_ev_vars :: [EvVar], -- ^ Includes equality constraints @@ -295,7 +303,9 @@ data HsBindLR idL idR } -- | Patterns Synonym Binding - | PatSynBind (PatSynBind idL idR) + | PatSynBind + (XPatSynBind idL idR) + (PatSynBind idL idR) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', -- 'ApiAnnotation.AnnWhere' @@ -303,7 +313,26 @@ data HsBindLR idL idR -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR) + | XHsBindsLR (XXHsBindsLR 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) = NPatBindTc + +type instance XVarBind (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XAbsBinds (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XPatSynBind (GhcPass pL) (GhcPass pR) = PlaceHolder +type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = PlaceHolder + -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -319,13 +348,18 @@ deriving instance (DataIdLR idL idR) => Data (HsBindLR idL idR) -- | Abtraction Bindings Export data ABExport p - = 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 - } -deriving instance (DataId p) => Data (ABExport p) + } + | XABExport (XXABExport p) + +type instance XABE (GhcPass p) = PlaceHolder +type instance XXABExport (GhcPass p) = PlaceHolder + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' @@ -336,14 +370,18 @@ deriving instance (DataId p) => Data (ABExport p) -- | Pattern Synonym binding data PatSynBind idL idR - = 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 - } -deriving instance (DataIdLR idL idR) => Data (PatSynBind idL idR) + } + | XPatSynBind (XXPatSynBind idL idR) + +type instance XPSB (GhcPass idL) (GhcPass idR) = PlaceHolder +type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = PlaceHolder {- Note [AbsBinds] @@ -581,9 +619,10 @@ Specifically, instance (idL ~ GhcPass pl, idR ~ GhcPass pr, OutputableBndrId idL, OutputableBndrId idR) => Outputable (HsLocalBindsLR idL idR) where - ppr (HsValBinds bs) = ppr bs - ppr (HsIPBinds bs) = ppr bs - ppr EmptyLocalBinds = empty + ppr (HsValBinds _ bs) = ppr bs + ppr (HsIPBinds _ bs) = ppr bs + ppr (EmptyLocalBinds _) = empty + ppr (XHsLocalBindsLR x) = ppr x instance (idL ~ GhcPass pl, idR ~ GhcPass pr, OutputableBndrId idL, OutputableBndrId idR) @@ -640,17 +679,25 @@ pprDeclList :: [SDoc] -> SDoc -- Braces with a space pprDeclList ds = pprDeeperList vcat ds ------------ -emptyLocalBinds :: HsLocalBindsLR a b -emptyLocalBinds = EmptyLocalBinds - -isEmptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool -isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds -isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds -isEmptyLocalBinds EmptyLocalBinds = True +emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) +emptyLocalBinds = EmptyLocalBinds noExt + +-- 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 -eqEmptyLocalBinds _ = False +eqEmptyLocalBinds (EmptyLocalBinds _) = True +eqEmptyLocalBinds _ = False isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs @@ -698,7 +745,7 @@ ppr_monobind (FunBind { fun_id = fun, $$ whenPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind matches $$ whenPprDebug (ppr wrap) -ppr_monobind (PatSynBind psb) = ppr psb +ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , abs_exports = exports, abs_binds = val_binds , abs_ev_binds = ev_binds }) @@ -716,14 +763,17 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , text "Evidence:" <+> ppr ev_binds ] else pprLHsBinds val_binds +ppr_monobind (XHsBindsLR x) = ppr x instance (OutputableBndrId p) => Outputable (ABExport 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) , 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 }) @@ -743,6 +793,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 @@ -765,13 +816,27 @@ pprTicks pp_no_debug pp_when_debug -- | Haskell Implicit Parameter Bindings data HsIPBinds id = IPBinds + (XIPBinds id) [LIPBind id] - TcEvBinds -- Only in typechecker output; binds - -- uses of the implicit parameters -deriving instance (DataIdLR id id) => Data (HsIPBinds id) + -- TcEvBinds -- Only in typechecker output; binds + -- -- uses of the implicit parameters + | XHsIPBinds (XXHsIPBinds 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) @@ -791,19 +856,27 @@ type LIPBind id = Located (IPBind id) -- For details on above see note [Api annotations] in ApiAnnotation data IPBind id - = IPBind (Either (Located HsIPName) (IdP id)) (LHsExpr id) -deriving instance (DataIdLR id id) => Data (IPBind id) + = IPBind + (XIPBind id) + (Either (Located HsIPName) (IdP id)) + (LHsExpr id) + | XCIPBind (XXIPBind 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 {- ************************************************************************ @@ -840,6 +913,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 @@ -852,7 +926,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 @@ -865,14 +939,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 -- @@ -883,7 +957,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 -- @@ -896,7 +970,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 @@ -911,7 +986,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 @@ -928,7 +1004,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 @@ -940,7 +1016,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 @@ -951,7 +1028,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 @@ -961,18 +1039,34 @@ 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))) - -deriving instance (DataIdLR pass pass) => Data (Sig pass) + | XSig (XXSig 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 -deriving instance (DataId pass) => Data (FixitySig pass) +data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity + | XFixitySig (XXFixitySig pass) + +type instance XFixitySig (GhcPass p) = PlaceHolder +type instance XXFixitySig (GhcPass p) = PlaceHolder -- | Type checker Specialisation Pragmas -- @@ -1054,17 +1148,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 @@ -1076,41 +1171,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 "#-}" @@ -1215,4 +1312,3 @@ data HsPatSynDir id = Unidirectional | ImplicitBidirectional | ExplicitBidirectional (MatchGroup id (LHsExpr id)) -deriving instance (DataIdLR id id) => Data (HsPatSynDir id) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 54314a9048..2cbdad3f70 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -132,6 +132,7 @@ type LHsDecl id = Located (HsDecl id) -- | A Haskell Declaration data HsDecl id + -- AZ:TODO:TTG HsDecl = TyClD (TyClDecl id) -- ^ Type or Class Declaration | InstD (InstDecl id) -- ^ Instance declaration | DerivD (DerivDecl id) -- ^ Deriving declaration @@ -147,7 +148,6 @@ data HsDecl id -- (Includes quasi-quotes) | DocD (DocDecl) -- ^ Documentation comment declaration | RoleAnnotD (RoleAnnotDecl id) -- ^ Role annotation declaration -deriving instance (DataIdLR id id) => Data (HsDecl id) -- NB: all top-level fixity decls are contained EITHER @@ -168,6 +168,7 @@ deriving instance (DataIdLR id id) => Data (HsDecl id) -- A 'HsDecl' is categorised into a 'HsGroup' before being -- fed to the renamer. data HsGroup id + -- AZ:TODO:TTG HsGroup = HsGroup { hs_valds :: HsValBinds id, hs_splcds :: [LSpliceDecl id], @@ -193,7 +194,6 @@ data HsGroup id hs_docs :: [LDocDecl] } -deriving instance (DataIdLR id id) => Data (HsGroup id) emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass a) emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } @@ -309,10 +309,10 @@ type LSpliceDecl pass = Located (SpliceDecl pass) -- | Splice Declaration data SpliceDecl id + -- AZ:TODO: TTG SpliceD = SpliceDecl -- Top level splice (Located (HsSplice id)) SpliceExplicitFlag -deriving instance (DataIdLR id id) => Data (SpliceDecl id) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (SpliceDecl p) where @@ -462,6 +462,7 @@ type LTyClDecl pass = Located (TyClDecl pass) -- | A type or class declaration. data TyClDecl pass + -- AZ:TODO: TTG TyClDecl = -- | @type/data family T :: *->*@ -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', @@ -535,8 +536,6 @@ data TyClDecl pass -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR id id) => Data (TyClDecl id) - -- Simple classifiers for TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -776,10 +775,10 @@ in RnSource for more info. -- | Type or Class Group data TyClGroup pass -- See Note [TyClGroups and dependency analysis] + -- AZ:TODO: TTG TyClGroups = TyClGroup { group_tyclds :: [LTyClDecl pass] , group_roles :: [LRoleAnnotDecl pass] , group_instds :: [LInstDecl pass] } -deriving instance (DataIdLR id id) => Data (TyClGroup id) emptyTyClGroup :: TyClGroup pass emptyTyClGroup = TyClGroup [] [] [] @@ -876,6 +875,7 @@ type LFamilyResultSig pass = Located (FamilyResultSig pass) -- | type Family Result Signature data FamilyResultSig pass = -- see Note [FamilyResultSig] + -- AZ:TODO: TTG FamilyResultSig NoSig -- ^ - 'ApiAnnotation.AnnKeywordId' : @@ -895,8 +895,6 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig] -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (FamilyResultSig pass) - -- | Located type Family Declaration type LFamilyDecl pass = Located (FamilyDecl pass) @@ -918,8 +916,6 @@ data FamilyDecl pass = FamilyDecl -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR id id) => Data (FamilyDecl id) - -- | Located Injectivity Annotation type LInjectivityAnn pass = Located (InjectivityAnn pass) @@ -937,7 +933,6 @@ data InjectivityAnn pass -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (InjectivityAnn pass) data FamilyInfo pass = DataFamily @@ -945,7 +940,6 @@ data FamilyInfo pass -- | 'Nothing' if we're in an hs-boot file and the user -- said "type family Foo x where .." | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) -deriving instance (DataIdLR pass pass) => Data (FamilyInfo pass) -- | Does this family declaration have a complete, user-supplied kind signature? famDeclHasCusk :: Maybe Bool @@ -1053,7 +1047,6 @@ data HsDataDefn pass -- The payload of a data type defn -- For details on above see note [Api annotations] in ApiAnnotation } -deriving instance (DataIdLR id id) => Data (HsDataDefn id) -- | Haskell Deriving clause type HsDeriving pass = Located [LHsDerivingClause pass] @@ -1089,7 +1082,6 @@ data HsDerivingClause pass -- -- should produce a derived instance for @C [a] (T b)@. } -deriving instance (DataIdLR id id) => Data (HsDerivingClause id) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDerivingClause p) where @@ -1183,7 +1175,6 @@ data ConDecl pass , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } -deriving instance (DataIdLR pass pass) => Data (ConDecl pass) {- Note [GADT abstract syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1416,7 +1407,6 @@ newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } -- 'ApiAnnotation.AnnInstance', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance DataIdLR pass pass => Data (TyFamInstDecl pass) ----------------- Data family instances ------------- @@ -1434,7 +1424,6 @@ newtype DataFamInstDecl pass -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance DataIdLR pass pass => Data (DataFamInstDecl pass) ----------------- Family instances (common types) ------------- @@ -1464,8 +1453,6 @@ data FamEqn pass pats rhs -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass, Data pats, Data rhs) - => Data (FamEqn pass pats rhs) ----------------- Class instances ------------- @@ -1494,8 +1481,6 @@ data ClsInstDecl pass -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR id id) => Data (ClsInstDecl id) - ----------------- Instances of all kinds ------------- @@ -1510,7 +1495,6 @@ data InstDecl pass -- Both class and family instances { dfid_inst :: DataFamInstDecl pass } | TyFamInstD -- type family instance { tfid_inst :: TyFamInstDecl pass } -deriving instance (DataIdLR id id) => Data (InstDecl id) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyFamInstDecl p) where @@ -1680,7 +1664,6 @@ data DerivDecl pass = DerivDecl -- For details on above see note [Api annotations] in ApiAnnotation } -deriving instance (DataIdLR pass pass) => Data (DerivDecl pass) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DerivDecl p) where @@ -1715,7 +1698,6 @@ data DefaultDecl pass -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (DefaultDecl pass) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (DefaultDecl p) where @@ -1759,7 +1741,6 @@ data ForeignDecl pass -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (ForeignDecl pass) {- In both ForeignImport and ForeignExport: sig_ty is the type given in the Haskell code @@ -1876,7 +1857,6 @@ type LRuleDecls pass = Located (RuleDecls pass) -- | Rule Declarations data RuleDecls pass = HsRules { rds_src :: SourceText , rds_rules :: [LRuleDecl pass] } -deriving instance (DataIdLR pass pass) => Data (RuleDecls pass) -- | Located Rule Declaration type LRuleDecl pass = Located (RuleDecl pass) @@ -1902,7 +1882,6 @@ data RuleDecl pass -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (RuleDecl pass) flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls @@ -1919,7 +1898,6 @@ data RuleBndr pass -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (RuleBndr pass) collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] @@ -2010,7 +1988,6 @@ data VectDecl pass (LHsSigType pass) | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now ClsInst -deriving instance (DataIdLR pass pass) => Data (VectDecl pass) lvectDeclName :: NamedThing (IdP pass) => LVectDecl pass -> Name lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name @@ -2108,14 +2085,12 @@ type LWarnDecls pass = Located (WarnDecls pass) data WarnDecls pass = Warnings { wd_src :: SourceText , wd_warnings :: [LWarnDecl pass] } -deriving instance (DataId pass) => Data (WarnDecls pass) -- | Located Warning pragma Declaration type LWarnDecl pass = Located (WarnDecl pass) -- | Warning pragma Declaration data WarnDecl pass = Warning [Located (IdP pass)] WarningTxt -deriving instance (DataId pass) => Data (WarnDecl pass) instance OutputableBndr (IdP pass) => Outputable (WarnDecls pass) where ppr (Warnings (SourceText src) decls) @@ -2148,7 +2123,6 @@ data AnnDecl pass = HsAnnotation -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (AnnDecl pass) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where ppr (HsAnnotation _ provenance expr) @@ -2196,7 +2170,6 @@ data RoleAnnotDecl pass -- 'ApiAnnotation.AnnRole' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataId pass) => Data (RoleAnnotDecl pass) instance OutputableBndr (IdP pass) => Outputable (RoleAnnotDecl pass) where ppr (RoleAnnotDecl ltycon roles) diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 92797faf40..7f6d3f8461 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -111,7 +111,6 @@ noPostTcTable = [] data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p , syn_arg_wraps :: [HsWrapper] , syn_res_wrap :: HsWrapper } -deriving instance (DataIdLR p p) => Data (SyntaxExpr p) -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) @@ -719,14 +718,12 @@ data HsExpr p | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor -deriving instance (DataIdLR p p) => Data (HsExpr p) -- | Extra data fields for a 'RecordCon', added by the type checker data RecordConTc = RecordConTc { rcon_con_like :: ConLike -- The data constructor or pattern synonym , rcon_con_expr :: PostTcExpr -- Instantiated constructor function - } deriving Data - + } -- | Extra data fields for a 'RecordUpd', added by the type checker data RecordUpdTc = RecordUpdTc @@ -862,7 +859,6 @@ 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 -deriving instance (DataIdLR id id) => Data (HsTupArg id) type instance XPresent (GhcPass _) = PlaceHolder @@ -1405,7 +1401,6 @@ data HsCmd id -- wrap :: arg1 "->" arg2 -- Then (HsCmdWrap wrap cmd) :: arg2 --> res | XCmd (XXCmd id) -- Note [Trees that Grow] extension point -deriving instance (DataIdLR id id) => Data (HsCmd id) type instance XCmdArrApp GhcPs = PlaceHolder type instance XCmdArrApp GhcRn = PlaceHolder @@ -1444,13 +1439,11 @@ data HsCmdTop p = HsCmdTop (XCmdTop p) (LHsCmd p) | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point -deriving instance (DataIdLR p p) => Data (HsCmdTop p) data CmdTopTc = CmdTopTc Type -- Nested tuple of inputs on the command's stack Type -- return type of the command (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] - deriving Data type instance XCmdTop GhcPs = PlaceHolder type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] @@ -1596,7 +1589,6 @@ data MatchGroup p body -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns -deriving instance (Data body,DataIdLR p p) => Data (MatchGroup p body) -- | Located Match type LMatch id body = Located (Match id body) @@ -1612,7 +1604,6 @@ data Match p body m_pats :: [LPat p], -- The patterns m_grhss :: (GRHSs p body) } -deriving instance (Data body,DataIdLR p p) => Data (Match p body) instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body) => Outputable (Match idR body) where @@ -1698,7 +1689,6 @@ data GRHSs p body grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause } -deriving instance (Data body,DataIdLR p p) => Data (GRHSs p body) -- | Located Guarded Right-Hand Side type LGRHS id body = Located (GRHS id body) @@ -1707,7 +1697,6 @@ type LGRHS id body = Located (GRHS id body) -- | Guarded Right Hand Side. data GRHS id body = GRHS [GuardLStmt id] -- Guards body -- Right hand side -deriving instance (Data body,DataIdLR id id) => Data (GRHS id body) -- We know the list must have at least one @Match@ in it. @@ -1960,8 +1949,6 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- With rebindable syntax the type might not -- be quite as simple as (m (tya, tyb, tyc)). } -deriving instance (Data body, DataIdLR idL idR) - => Data (StmtLR idL idR body) data TransForm -- The 'f' below is the 'using' function, 'e' is the by function = ThenForm -- then f or then f by e (depending on trS_by) @@ -1976,7 +1963,6 @@ data ParStmtBlock idL idR [IdP idR] -- The variables to be returned (SyntaxExpr idR) -- The return operator | XParStmtBlock (XXParStmtBlock idL idR) -deriving instance (DataIdLR idL idR) => Data (ParStmtBlock idL idR) type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = PlaceHolder @@ -1996,7 +1982,6 @@ data ApplicativeArg idL (LPat idL) -- (v1,...,vn) -- AZ: May need to bring back idR? -deriving instance (DataIdLR idL idL) => Data (ApplicativeArg idL) {- Note [The type of bind in Stmts] @@ -2344,7 +2329,6 @@ data HsSplice id ThModFinalizers -- TH finalizers produced by the splice. (HsSplicedThing id) -- The result of splicing | XSplice (XXSplice id) -- Note [Trees that Grow] extension point -deriving instance (DataIdLR id id) => Data (HsSplice id) type instance XTypedSplice (GhcPass _) = PlaceHolder type instance XUntypedSplice (GhcPass _) = PlaceHolder @@ -2391,7 +2375,6 @@ data HsSplicedThing id | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern -deriving instance (DataIdLR id id) => Data (HsSplicedThing id) -- See Note [Pending Splices] type SplicePointName = Name @@ -2400,7 +2383,6 @@ type SplicePointName = Name data PendingRnSplice -- AZ:TODO: The hard-coded GhcRn feels wrong. How to force the PostRn? = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) - deriving Data data UntypedSpliceFlavour = UntypedExpSplice @@ -2413,7 +2395,6 @@ data UntypedSpliceFlavour data PendingTcSplice -- AZ:TODO: The hard-coded GhcTc feels wrong. How to force the PostTc? = PendingTcSplice SplicePointName (LHsExpr GhcTc) - deriving Data {- Note [Pending Splices] @@ -2541,7 +2522,6 @@ data HsBracket p -- (The Bool flag is used only in pprHsBracket) | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] | XBracket (XXBracket p) -- Note [Trees that Grow] extension point -deriving instance (DataIdLR p p) => Data (HsBracket p) type instance XExpBr (GhcPass _) = PlaceHolder type instance XPatBr (GhcPass _) = PlaceHolder @@ -2605,7 +2585,6 @@ data ArithSeqInfo id | FromThenTo (LHsExpr id) (LHsExpr id) (LHsExpr id) -deriving instance (DataIdLR id id) => Data (ArithSeqInfo id) -- AZ: Sould ArithSeqInfo have a TTG extension? instance (p ~ GhcPass pass, OutputableBndrId p) diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index e8fa7a4e23..49ae108546 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -13,8 +13,7 @@ import SrcLoc ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) import BasicTypes ( SpliceExplicitFlag(..)) -import HsExtension ( OutputableBndrId, DataIdLR, GhcPass ) -import Data.Data hiding ( Fixity ) +import HsExtension ( OutputableBndrId, GhcPass ) type role HsExpr nominal type role HsCmd nominal @@ -29,13 +28,6 @@ data MatchGroup (a :: *) (body :: *) data GRHSs (a :: *) (body :: *) data SyntaxExpr (i :: *) -instance (DataIdLR id id) => Data (HsSplice id) -instance (DataIdLR p p) => Data (HsExpr p) -instance (DataIdLR id id) => Data (HsCmd id) -instance (Data body,DataIdLR p p) => Data (MatchGroup p body) -instance (Data body,DataIdLR p p) => Data (GRHSs p body) -instance (DataIdLR p p) => Data (SyntaxExpr p) - instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index 779ecc53e4..81ffd05d78 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -83,8 +83,6 @@ type instance PostTc GhcPs ty = PlaceHolder type instance PostTc GhcRn ty = PlaceHolder type instance PostTc GhcTc ty = ty --- deriving instance (Data ty) => Data (PostTc (GhcPass 'Parsed) ty) - -- | Types that are not defined until after renaming type family PostRn x ty -- Note [Pass sensitive types] in PlaceHolder type instance PostRn GhcPs ty = PlaceHolder @@ -99,52 +97,23 @@ type instance IdP GhcTc = Id type LIdP p = Located (IdP p) --- --------------------------------------------------------------------- --- type families for the Pat extension points -type family XWildPat x -type family XVarPat x -type family XLazyPat x -type family XAsPat x -type family XParPat x -type family XBangPat x -type family XListPat x -type family XTuplePat x -type family XSumPat x -type family XPArrPat x -type family XConPat x -type family XViewPat x -type family XSplicePat x -type family XLitPat x -type family XNPat x -type family XNPlusKPat x -type family XSigPat x -type family XCoPat x -type family XXPat x +-- ===================================================================== +-- Type families for the HsBinds extension points +-- HsLocalBindsLR type families +type family XHsValBinds x x' +type family XHsIPBinds x x' +type family XEmptyLocalBinds x x' +type family XXHsLocalBindsLR x x' -type ForallXPat (c :: * -> Constraint) (x :: *) = - ( c (XWildPat x) - , c (XVarPat x) - , c (XLazyPat x) - , c (XAsPat x) - , c (XParPat x) - , c (XBangPat x) - , c (XListPat x) - , c (XTuplePat x) - , c (XSumPat x) - , c (XPArrPat x) - , c (XViewPat x) - , c (XSplicePat x) - , c (XLitPat x) - , c (XNPat x) - , c (XNPlusKPat x) - , c (XSigPat x) - , c (XCoPat x) - , c (XXPat x) +type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XHsValBinds x x') + , c (XHsIPBinds x x') + , c (XEmptyLocalBinds x x') + , c (XXHsLocalBindsLR x x') ) --- --------------------------------------------------------------------- --- ValBindsLR type families +-- ValBindsLR type families type family XValBinds x x' type family XXValBindsLR x x' @@ -153,143 +122,106 @@ type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = , c (XXValBindsLR x x') ) --- We define a type family for each extension point. This is based on prepending --- 'X' to the constructor name, for ease of reference. -type family XHsChar x -type family XHsCharPrim x -type family XHsString x -type family XHsStringPrim x -type family XHsInt x -type family XHsIntPrim x -type family XHsWordPrim x -type family XHsInt64Prim x -type family XHsWord64Prim x -type family XHsInteger x -type family XHsRat x -type family XHsFloatPrim x -type family XHsDoublePrim x -type family XXLit x --- | Helper to apply a constraint to all extension points. It has one --- entry per extension point type family. -type ForallXHsLit (c :: * -> Constraint) (x :: *) = - ( c (XHsChar x) - , c (XHsCharPrim x) - , c (XHsDoublePrim x) - , c (XHsFloatPrim x) - , c (XHsInt x) - , c (XHsInt64Prim x) - , c (XHsIntPrim x) - , c (XHsInteger x) - , c (XHsRat x) - , c (XHsString x) - , c (XHsStringPrim x) - , c (XHsWord64Prim x) - , c (XHsWordPrim x) - , c (XXLit x) - ) +-- HsBindsLR type families +type family XFunBind x x' +type family XPatBind x x' +type family XVarBind x x' +type family XAbsBinds x x' +type family XPatSynBind x x' +type family XXHsBindsLR x x' + +type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XFunBind x x') + , c (XPatBind x x') + , c (XVarBind x x') + , c (XAbsBinds x x') + , c (XPatSynBind x x') + , c (XXHsBindsLR x x') + ) -type family XOverLit x -type family XXOverLit x +-- ABExport type families +type family XABE x +type family XXABExport x -type ForallXOverLit (c :: * -> Constraint) (x :: *) = - ( c (XOverLit x) - , c (XXOverLit x) +type ForallXABExport (c :: * -> Constraint) (x :: *) = + ( c (XABE x) + , c (XXABExport x) ) --- --------------------------------------------------------------------- --- Type families for the Type type families - -type family XForAllTy x -type family XQualTy x -type family XTyVar x -type family XAppsTy x -type family XAppTy x -type family XFunTy x -type family XListTy x -type family XPArrTy x -type family XTupleTy x -type family XSumTy x -type family XOpTy x -type family XParTy x -type family XIParamTy x -type family XEqTy x -type family XKindSig x -type family XSpliceTy x -type family XDocTy x -type family XBangTy x -type family XRecTy x -type family XExplicitListTy x -type family XExplicitTupleTy x -type family XTyLit x -type family XWildCardTy x -type family XXType x +-- PatSynBind type families +type family XPSB x x' +type family XXPatSynBind x x' --- | Helper to apply a constraint to all extension points. It has one --- entry per extension point type family. -type ForallXType (c :: * -> Constraint) (x :: *) = - ( c (XForAllTy x) - , c (XQualTy x) - , c (XTyVar x) - , c (XAppsTy x) - , c (XAppTy x) - , c (XFunTy x) - , c (XListTy x) - , c (XPArrTy x) - , c (XTupleTy x) - , c (XSumTy x) - , c (XOpTy x) - , c (XParTy x) - , c (XIParamTy x) - , c (XEqTy x) - , c (XKindSig x) - , c (XSpliceTy x) - , c (XDocTy x) - , c (XBangTy x) - , c (XRecTy x) - , c (XExplicitListTy x) - , c (XExplicitTupleTy x) - , c (XTyLit x) - , c (XWildCardTy x) - , c (XXType 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 family XUserTyVar x -type family XKindedTyVar x -type family XXTyVarBndr x +type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) = + ( c (XIPBinds x) + , c (XXHsIPBinds x) + ) -type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = - ( c (XUserTyVar x) - , c (XKindedTyVar x) - , c (XXTyVarBndr 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) + ) -type family XAppInfix x -type family XAppPrefix x -type family XXAppType x +-- FixitySig type families +type family XFixitySig x +type family XXFixitySig x -type ForallXAppType (c :: * -> Constraint) (x :: *) = - ( c (XAppInfix x) - , c (XAppPrefix x) - , c (XXAppType x) +type ForallXFixitySig (c :: * -> Constraint) (x :: *) = + ( c (XFixitySig x) + , c (XXFixitySig x) ) --- --------------------------------------------------------------------- +-- ===================================================================== +-- Type families for the HsDecls extension points -type family XFieldOcc x -type family XXFieldOcc x -type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = - ( c (XFieldOcc x) - , c (XXFieldOcc x) - ) +-- TODO --- --------------------------------------------------------------------- --- Type families for the HsExpr type families +-- ===================================================================== +-- Type families for the HsExpr extension points type family XVar x type family XUnboundVar x @@ -504,6 +436,199 @@ type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) = , c (XXParStmtBlock x x') ) +-- ===================================================================== +-- Type families for the HsImpExp extension points + +-- TODO + +-- ===================================================================== +-- Type families for the HsLit extension points + +-- We define a type family for each extension point. This is based on prepending +-- 'X' to the constructor name, for ease of reference. +type family XHsChar x +type family XHsCharPrim x +type family XHsString x +type family XHsStringPrim x +type family XHsInt x +type family XHsIntPrim x +type family XHsWordPrim x +type family XHsInt64Prim x +type family XHsWord64Prim x +type family XHsInteger x +type family XHsRat x +type family XHsFloatPrim x +type family XHsDoublePrim x +type family XXLit x + +-- | Helper to apply a constraint to all extension points. It has one +-- entry per extension point type family. +type ForallXHsLit (c :: * -> Constraint) (x :: *) = + ( c (XHsChar x) + , c (XHsCharPrim x) + , c (XHsDoublePrim x) + , c (XHsFloatPrim x) + , c (XHsInt x) + , c (XHsInt64Prim x) + , c (XHsIntPrim x) + , c (XHsInteger x) + , c (XHsRat x) + , c (XHsString x) + , c (XHsStringPrim x) + , c (XHsWord64Prim x) + , c (XHsWordPrim x) + , c (XXLit x) + ) + +type family XOverLit x +type family XXOverLit x + +type ForallXOverLit (c :: * -> Constraint) (x :: *) = + ( c (XOverLit x) + , c (XXOverLit x) + ) + +-- ===================================================================== +-- Type families for the HsPat extension points + +type family XWildPat x +type family XVarPat x +type family XLazyPat x +type family XAsPat x +type family XParPat x +type family XBangPat x +type family XListPat x +type family XTuplePat x +type family XSumPat x +type family XPArrPat x +type family XConPat x +type family XViewPat x +type family XSplicePat x +type family XLitPat x +type family XNPat x +type family XNPlusKPat x +type family XSigPat x +type family XCoPat x +type family XXPat x + + +type ForallXPat (c :: * -> Constraint) (x :: *) = + ( c (XWildPat x) + , c (XVarPat x) + , c (XLazyPat x) + , c (XAsPat x) + , c (XParPat x) + , c (XBangPat x) + , c (XListPat x) + , c (XTuplePat x) + , c (XSumPat x) + , c (XPArrPat x) + , c (XViewPat x) + , c (XSplicePat x) + , c (XLitPat x) + , c (XNPat x) + , c (XNPlusKPat x) + , c (XSigPat x) + , c (XCoPat x) + , c (XXPat x) + ) + +-- ===================================================================== +-- Type families for the HsTypes type families + +type family XForAllTy x +type family XQualTy x +type family XTyVar x +type family XAppsTy x +type family XAppTy x +type family XFunTy x +type family XListTy x +type family XPArrTy x +type family XTupleTy x +type family XSumTy x +type family XOpTy x +type family XParTy x +type family XIParamTy x +type family XEqTy x +type family XKindSig x +type family XSpliceTy x +type family XDocTy x +type family XBangTy x +type family XRecTy x +type family XExplicitListTy x +type family XExplicitTupleTy x +type family XTyLit x +type family XWildCardTy x +type family XXType x + +-- | Helper to apply a constraint to all extension points. It has one +-- entry per extension point type family. +type ForallXType (c :: * -> Constraint) (x :: *) = + ( c (XForAllTy x) + , c (XQualTy x) + , c (XTyVar x) + , c (XAppsTy x) + , c (XAppTy x) + , c (XFunTy x) + , c (XListTy x) + , c (XPArrTy x) + , c (XTupleTy x) + , c (XSumTy x) + , c (XOpTy x) + , c (XParTy x) + , c (XIParamTy x) + , c (XEqTy x) + , c (XKindSig x) + , c (XSpliceTy x) + , c (XDocTy x) + , c (XBangTy x) + , c (XRecTy x) + , c (XExplicitListTy x) + , c (XExplicitTupleTy x) + , c (XTyLit x) + , c (XWildCardTy x) + , c (XXType x) + ) + +-- --------------------------------------------------------------------- + +type family XUserTyVar x +type family XKindedTyVar x +type family XXTyVarBndr x + +type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = + ( c (XUserTyVar x) + , c (XKindedTyVar x) + , c (XXTyVarBndr x) + ) + +-- --------------------------------------------------------------------- + +type family XAppInfix x +type family XAppPrefix x +type family XXAppType x + +type ForallXAppType (c :: * -> Constraint) (x :: *) = + ( c (XAppInfix x) + , c (XAppPrefix x) + , c (XXAppType x) + ) + +-- --------------------------------------------------------------------- + +type family XFieldOcc x +type family XXFieldOcc x + +type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = + ( c (XFieldOcc x) + , c (XXFieldOcc x) + ) + + +-- ===================================================================== +-- End of Type family definitions +-- ===================================================================== + -- ---------------------------------------------------------------------- -- | Conversion of annotations from one type index to another. This is required -- where the AST is converted from one pass to another, and the extension values @@ -551,6 +676,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) @@ -587,12 +721,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)) @@ -616,13 +755,29 @@ type DataId p = type DataIdLR pL pR = ( DataId pL , DataId pR - , ForallXValBindsLR Data pL pR - , ForallXValBindsLR Data pL pL - , ForallXValBindsLR Data pR pR - , ForallXParStmtBlock Data pL pR - , ForallXParStmtBlock Data pL pL - , ForallXParStmtBlock Data pR pR + , ForallXHsLocalBindsLR Data pL pR + , ForallXHsLocalBindsLR Data pL pL + , ForallXHsLocalBindsLR Data pR pR + + , ForallXValBindsLR Data pL pR + , ForallXValBindsLR Data pL pL + , ForallXValBindsLR Data pR pR + + , ForallXHsBindsLR Data pL pR + , ForallXHsBindsLR Data pL pL + , ForallXHsBindsLR 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/HsInstances.hs b/compiler/hsSyn/HsInstances.hs new file mode 100644 index 0000000000..1059cb1e0e --- /dev/null +++ b/compiler/hsSyn/HsInstances.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module HsInstances where + +-- This module defines the Data instances for the hsSyn AST. + +-- It happens here to avoid massive constraint types on the AST with concomitant +-- slow GHC bootstrap times. + +-- UndecidableInstances ? + +import Data.Data hiding ( Fixity ) + +import HsExtension +import HsBinds +import HsDecls +import HsExpr +import HsLit +import HsTypes +import HsPat + +-- --------------------------------------------------------------------- +-- Data derivations from HsSyn ----------------------------------------- + +-- --------------------------------------------------------------------- +-- Data derivations from HsBinds --------------------------------------- + +-- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR) +deriving instance Data (HsLocalBindsLR GhcPs GhcPs) +deriving instance Data (HsLocalBindsLR GhcPs GhcRn) +deriving instance Data (HsLocalBindsLR GhcRn GhcRn) +deriving instance Data (HsLocalBindsLR GhcTc GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR) +deriving instance Data (HsValBindsLR GhcPs GhcPs) +deriving instance Data (HsValBindsLR GhcPs GhcRn) +deriving instance Data (HsValBindsLR GhcRn GhcRn) +deriving instance Data (HsValBindsLR GhcTc GhcTc) + +-- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) +deriving instance Data (NHsValBindsLR GhcPs) +deriving instance Data (NHsValBindsLR GhcRn) +deriving instance Data (NHsValBindsLR GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR) +deriving instance Data (HsBindLR GhcPs GhcPs) +deriving instance Data (HsBindLR GhcPs GhcRn) +deriving instance Data (HsBindLR GhcRn GhcRn) +deriving instance Data (HsBindLR GhcTc GhcTc) + +-- deriving instance (DataId p) => Data (ABExport p) +deriving instance Data (ABExport GhcPs) +deriving instance Data (ABExport GhcRn) +deriving instance Data (ABExport GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) +deriving instance Data (PatSynBind GhcPs GhcPs) +deriving instance Data (PatSynBind GhcPs GhcRn) +deriving instance Data (PatSynBind GhcRn GhcRn) +deriving instance Data (PatSynBind GhcTc GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsIPBinds p) +deriving instance Data (HsIPBinds GhcPs) +deriving instance Data (HsIPBinds GhcRn) +deriving instance Data (HsIPBinds GhcTc) + +-- deriving instance (DataIdLR p p) => Data (IPBind p) +deriving instance Data (IPBind GhcPs) +deriving instance Data (IPBind GhcRn) +deriving instance Data (IPBind GhcTc) + +-- deriving instance (DataIdLR p p) => Data (Sig p) +deriving instance Data (Sig GhcPs) +deriving instance Data (Sig GhcRn) +deriving instance Data (Sig GhcTc) + +-- deriving instance (DataId p) => Data (FixitySig p) +deriving instance Data (FixitySig GhcPs) +deriving instance Data (FixitySig GhcRn) +deriving instance Data (FixitySig GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsPatSynDir p) +deriving instance Data (HsPatSynDir GhcPs) +deriving instance Data (HsPatSynDir GhcRn) +deriving instance Data (HsPatSynDir GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from HsDecls --------------------------------------- + +-- deriving instance (DataIdLR p p) => Data (HsDecl p) +deriving instance Data (HsDecl GhcPs) +deriving instance Data (HsDecl GhcRn) +deriving instance Data (HsDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsGroup p) +deriving instance Data (HsGroup GhcPs) +deriving instance Data (HsGroup GhcRn) +deriving instance Data (HsGroup GhcTc) + +-- deriving instance (DataIdLR p p) => Data (SpliceDecl p) +deriving instance Data (SpliceDecl GhcPs) +deriving instance Data (SpliceDecl GhcRn) +deriving instance Data (SpliceDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (TyClDecl p) +deriving instance Data (TyClDecl GhcPs) +deriving instance Data (TyClDecl GhcRn) +deriving instance Data (TyClDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (TyClGroup p) +deriving instance Data (TyClGroup GhcPs) +deriving instance Data (TyClGroup GhcRn) +deriving instance Data (TyClGroup GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyResultSig p) +deriving instance Data (FamilyResultSig GhcPs) +deriving instance Data (FamilyResultSig GhcRn) +deriving instance Data (FamilyResultSig GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyDecl p) +deriving instance Data (FamilyDecl GhcPs) +deriving instance Data (FamilyDecl GhcRn) +deriving instance Data (FamilyDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (InjectivityAnn p) +deriving instance Data (InjectivityAnn GhcPs) +deriving instance Data (InjectivityAnn GhcRn) +deriving instance Data (InjectivityAnn GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyInfo p) +deriving instance Data (FamilyInfo GhcPs) +deriving instance Data (FamilyInfo GhcRn) +deriving instance Data (FamilyInfo GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsDataDefn p) +deriving instance Data (HsDataDefn GhcPs) +deriving instance Data (HsDataDefn GhcRn) +deriving instance Data (HsDataDefn GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsDerivingClause p) +deriving instance Data (HsDerivingClause GhcPs) +deriving instance Data (HsDerivingClause GhcRn) +deriving instance Data (HsDerivingClause GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ConDecl p) +deriving instance Data (ConDecl GhcPs) +deriving instance Data (ConDecl GhcRn) +deriving instance Data (ConDecl GhcTc) + +-- deriving instance DataIdLR p p => Data (TyFamInstDecl p) +deriving instance Data (TyFamInstDecl GhcPs) +deriving instance Data (TyFamInstDecl GhcRn) +deriving instance Data (TyFamInstDecl GhcTc) + +-- deriving instance DataIdLR p p => Data (DataFamInstDecl p) +deriving instance Data (DataFamInstDecl GhcPs) +deriving instance Data (DataFamInstDecl GhcRn) +deriving instance Data (DataFamInstDecl GhcTc) + +-- deriving instance (DataIdLR p p,Data pats,Data rhs)=>Data (FamEqn p pats rhs) +deriving instance (Data pats,Data rhs) => Data (FamEqn GhcPs pats rhs) +deriving instance (Data pats,Data rhs) => Data (FamEqn GhcRn pats rhs) +deriving instance (Data pats,Data rhs) => Data (FamEqn GhcTc pats rhs) + +-- deriving instance (DataIdLR p p) => Data (ClsInstDecl p) +deriving instance Data (ClsInstDecl GhcPs) +deriving instance Data (ClsInstDecl GhcRn) +deriving instance Data (ClsInstDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (InstDecl p) +deriving instance Data (InstDecl GhcPs) +deriving instance Data (InstDecl GhcRn) +deriving instance Data (InstDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DerivDecl p) +deriving instance Data (DerivDecl GhcPs) +deriving instance Data (DerivDecl GhcRn) +deriving instance Data (DerivDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DefaultDecl p) +deriving instance Data (DefaultDecl GhcPs) +deriving instance Data (DefaultDecl GhcRn) +deriving instance Data (DefaultDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ForeignDecl p) +deriving instance Data (ForeignDecl GhcPs) +deriving instance Data (ForeignDecl GhcRn) +deriving instance Data (ForeignDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleDecls p) +deriving instance Data (RuleDecls GhcPs) +deriving instance Data (RuleDecls GhcRn) +deriving instance Data (RuleDecls GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleDecl p) +deriving instance Data (RuleDecl GhcPs) +deriving instance Data (RuleDecl GhcRn) +deriving instance Data (RuleDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleBndr p) +deriving instance Data (RuleBndr GhcPs) +deriving instance Data (RuleBndr GhcRn) +deriving instance Data (RuleBndr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (VectDecl p) +deriving instance Data (VectDecl GhcPs) +deriving instance Data (VectDecl GhcRn) +deriving instance Data (VectDecl GhcTc) + +-- deriving instance (DataId p) => Data (WarnDecls p) +deriving instance Data (WarnDecls GhcPs) +deriving instance Data (WarnDecls GhcRn) +deriving instance Data (WarnDecls GhcTc) + +-- deriving instance (DataId p) => Data (WarnDecl p) +deriving instance Data (WarnDecl GhcPs) +deriving instance Data (WarnDecl GhcRn) +deriving instance Data (WarnDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (AnnDecl p) +deriving instance Data (AnnDecl GhcPs) +deriving instance Data (AnnDecl GhcRn) +deriving instance Data (AnnDecl GhcTc) + +-- deriving instance (DataId p) => Data (RoleAnnotDecl p) +deriving instance Data (RoleAnnotDecl GhcPs) +deriving instance Data (RoleAnnotDecl GhcRn) +deriving instance Data (RoleAnnotDecl GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from HsExpr ---------------------------------------- + +-- deriving instance (DataIdLR p p) => Data (SyntaxExpr p) +deriving instance Data (SyntaxExpr GhcPs) +deriving instance Data (SyntaxExpr GhcRn) +deriving instance Data (SyntaxExpr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsExpr p) +deriving instance Data (HsExpr GhcPs) +deriving instance Data (HsExpr GhcRn) +deriving instance Data (HsExpr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsTupArg p) +deriving instance Data (HsTupArg GhcPs) +deriving instance Data (HsTupArg GhcRn) +deriving instance Data (HsTupArg GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsCmd p) +deriving instance Data (HsCmd GhcPs) +deriving instance Data (HsCmd GhcRn) +deriving instance Data (HsCmd GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsCmdTop p) +deriving instance Data (HsCmdTop GhcPs) +deriving instance Data (HsCmdTop GhcRn) +deriving instance Data (HsCmdTop GhcTc) + +-- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body) +deriving instance (Data body) => Data (MatchGroup GhcPs body) +deriving instance (Data body) => Data (MatchGroup GhcRn body) +deriving instance (Data body) => Data (MatchGroup GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (Match p body) +deriving instance (Data body) => Data (Match GhcPs body) +deriving instance (Data body) => Data (Match GhcRn body) +deriving instance (Data body) => Data (Match GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (GRHSs p body) +deriving instance (Data body) => Data (GRHSs GhcPs body) +deriving instance (Data body) => Data (GRHSs GhcRn body) +deriving instance (Data body) => Data (GRHSs GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (GRHS p body) +deriving instance (Data body) => Data (GRHS GhcPs body) +deriving instance (Data body) => Data (GRHS GhcRn body) +deriving instance (Data body) => Data (GRHS GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (StmtLR p p body) +deriving instance (Data body) => Data (StmtLR GhcPs GhcPs body) +deriving instance (Data body) => Data (StmtLR GhcPs GhcRn body) +deriving instance (Data body) => Data (StmtLR GhcRn GhcRn body) +deriving instance (Data body) => Data (StmtLR GhcTc GhcTc body) + +-- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p) +deriving instance Data (ParStmtBlock GhcPs GhcPs) +deriving instance Data (ParStmtBlock GhcPs GhcRn) +deriving instance Data (ParStmtBlock GhcRn GhcRn) +deriving instance Data (ParStmtBlock GhcTc GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ApplicativeArg p) +deriving instance Data (ApplicativeArg GhcPs) +deriving instance Data (ApplicativeArg GhcRn) +deriving instance Data (ApplicativeArg GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsSplice p) +deriving instance Data (HsSplice GhcPs) +deriving instance Data (HsSplice GhcRn) +deriving instance Data (HsSplice GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsSplicedThing p) +deriving instance Data (HsSplicedThing GhcPs) +deriving instance Data (HsSplicedThing GhcRn) +deriving instance Data (HsSplicedThing GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsBracket p) +deriving instance Data (HsBracket GhcPs) +deriving instance Data (HsBracket GhcRn) +deriving instance Data (HsBracket GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p) +deriving instance Data (ArithSeqInfo GhcPs) +deriving instance Data (ArithSeqInfo GhcRn) +deriving instance Data (ArithSeqInfo GhcTc) + +deriving instance Data RecordConTc +deriving instance Data CmdTopTc +deriving instance Data PendingRnSplice +deriving instance Data PendingTcSplice + +-- --------------------------------------------------------------------- +-- Data derivations from HsLit ---------------------------------------- + +-- deriving instance (DataId p) => Data (HsLit p) +deriving instance Data (HsLit GhcPs) +deriving instance Data (HsLit GhcRn) +deriving instance Data (HsLit GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsOverLit p) +deriving instance Data (HsOverLit GhcPs) +deriving instance Data (HsOverLit GhcRn) +deriving instance Data (HsOverLit GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from HsPat ----------------------------------------- + +-- deriving instance (DataIdLR p p) => Data (Pat p) +deriving instance Data (Pat GhcPs) +deriving instance Data (Pat GhcRn) +deriving instance Data (Pat GhcTc) + +-- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body) +deriving instance (Data body) => Data (HsRecFields GhcPs body) +deriving instance (Data body) => Data (HsRecFields GhcRn body) +deriving instance (Data body) => Data (HsRecFields GhcTc body) + +-- --------------------------------------------------------------------- +-- Data derivations from HsTypes --------------------------------------- + +-- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) +deriving instance Data (LHsQTyVars GhcPs) +deriving instance Data (LHsQTyVars GhcRn) +deriving instance Data (LHsQTyVars GhcTc) + +-- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing) +deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing) +deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing) +deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing) + +-- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing) + +-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) +deriving instance Data (HsTyVarBndr GhcPs) +deriving instance Data (HsTyVarBndr GhcRn) +deriving instance Data (HsTyVarBndr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsType p) +deriving instance Data (HsType GhcPs) +deriving instance Data (HsType GhcRn) +deriving instance Data (HsType GhcTc) + +-- deriving instance (DataId p) => Data (HsWildCardInfo p) +deriving instance Data (HsWildCardInfo GhcPs) +deriving instance Data (HsWildCardInfo GhcRn) +deriving instance Data (HsWildCardInfo GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsAppType p) +deriving instance Data (HsAppType GhcPs) +deriving instance Data (HsAppType GhcRn) +deriving instance Data (HsAppType GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ConDeclField p) +deriving instance Data (ConDeclField GhcPs) +deriving instance Data (ConDeclField GhcRn) +deriving instance Data (ConDeclField GhcTc) + +-- deriving instance (DataId p) => Data (FieldOcc p) +deriving instance Data (FieldOcc GhcPs) +deriving instance Data (FieldOcc GhcRn) +deriving instance Data (FieldOcc GhcTc) + +-- deriving instance DataId p => Data (AmbiguousFieldOcc p) +deriving instance Data (AmbiguousFieldOcc GhcPs) +deriving instance Data (AmbiguousFieldOcc GhcRn) +deriving instance Data (AmbiguousFieldOcc GhcTc) + + +-- --------------------------------------------------------------------- diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index 182d00a929..1a38296e5d 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -79,8 +79,6 @@ data HsLit x | XLit (XXLit x) -deriving instance (DataId x) => Data (HsLit x) - type instance XHsChar (GhcPass _) = SourceText type instance XHsCharPrim (GhcPass _) = SourceText type instance XHsString (GhcPass _) = SourceText @@ -121,7 +119,6 @@ data HsOverLit p | XOverLit (XXOverLit p) -deriving instance (DataIdLR p p) => Data (HsOverLit p) data OverLitTc = OverLitTc { diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 8ffde32b5a..5732c3d512 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -279,7 +279,6 @@ data Pat p -- | Trees that Grow extension point for new constructors | XPat (XXPat p) -deriving instance (DataIdLR p p) => Data (Pat p) -- --------------------------------------------------------------------- @@ -353,7 +352,6 @@ data HsRecFields p arg -- A bunch of record fields = HsRecFields { rec_flds :: [LHsRecField p arg], rec_dotdot :: Maybe Int } -- Note [DotDot fields] deriving (Functor, Foldable, Traversable) -deriving instance (DataId p, Data arg) => Data (HsRecFields p arg) -- Note [DotDot fields] diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index d9a4d79412..b7efb1c28c 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -9,13 +9,11 @@ module HsPat where import SrcLoc( Located ) -import Data.Data hiding (Fixity) import Outputable -import HsExtension ( DataIdLR, OutputableBndrId, GhcPass ) +import HsExtension ( OutputableBndrId, GhcPass ) type role Pat nominal data Pat (i :: *) type LPat i = Located (Pat i) -instance (DataIdLR p p) => Data (Pat p) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index 1534491a47..b9abcf2683 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -16,6 +16,7 @@ therefore, is almost nothing but re-exporting. -- in module PlaceHolder {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data module HsSyn ( module HsBinds, @@ -31,7 +32,7 @@ module HsSyn ( module HsExtension, Fixity, - HsModule(..) + HsModule(..), ) where -- friends: @@ -49,6 +50,7 @@ import HsTypes import BasicTypes ( Fixity, WarningTxt ) import HsUtils import HsDoc +import HsInstances () -- others: import Outputable @@ -111,7 +113,10 @@ data HsModule name -- hsmodImports,hsmodDecls if this style is used. -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR name name) => Data (HsModule name) +-- deriving instance (DataIdLR name name) => Data (HsModule name) +deriving instance Data (HsModule GhcPs) +deriving instance Data (HsModule GhcRn) +deriving instance Data (HsModule GhcTc) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 5be6ddb26e..6d8a6608fb 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -270,7 +270,6 @@ data LHsQTyVars pass -- See Note [HsType binders] -- See Note [Dependent LHsQTyVars] in TcHsType } -deriving instance (DataIdLR pass pass) => Data (LHsQTyVars pass) mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs mkHsQTvs tvs = HsQTvs { hsq_implicit = placeHolder, hsq_explicit = tvs @@ -300,7 +299,6 @@ data HsImplicitBndrs pass thing -- See Note [HsType binders] -- is the payload closed? Used in -- TcHsType.decideKindGeneralisationPlan } -deriving instance (DataId pass, Data thing) => Data (HsImplicitBndrs pass thing) -- | Haskell Wildcard Binders data HsWildCardBndrs pass thing @@ -316,8 +314,6 @@ data HsWildCardBndrs pass thing -- it's still there in the hsc_body. } -deriving instance (DataId pass, Data thing) => Data (HsWildCardBndrs pass thing) - -- | Located Haskell Signature Type type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only @@ -420,7 +416,6 @@ data HsTyVarBndr pass | XTyVarBndr (XXTyVarBndr pass) -deriving instance (DataIdLR pass pass) => Data (HsTyVarBndr pass) type instance XUserTyVar (GhcPass _) = PlaceHolder type instance XKindedTyVar (GhcPass _) = PlaceHolder @@ -627,7 +622,6 @@ data HsType pass -- For adding new constructors via Trees that Grow | XHsType (XXType pass) -deriving instance (DataIdLR pass pass) => Data (HsType pass) data NewHsTypeX = NHsCoreTy Type -- An escape hatch for tunnelling a *closed* @@ -692,7 +686,6 @@ newtype HsWildCardInfo pass -- See Note [The wildcard story for types] = AnonWildCard (PostRn pass (Located Name)) -- A anonymous wild card ('_'). A fresh Name is generated for -- each individual anonymous wildcard during renaming -deriving instance (DataId pass) => Data (HsWildCardInfo pass) -- | Located Haskell Application Type type LHsAppType pass = Located (HsAppType pass) @@ -706,7 +699,6 @@ data HsAppType pass (LHsType pass) -- anything else, including things like (+) | XAppType (XXAppType pass) -deriving instance (DataIdLR pass pass) => Data (HsAppType pass) type instance XAppInfix (GhcPass _) = PlaceHolder type instance XAppPrefix (GhcPass _) = PlaceHolder @@ -855,7 +847,6 @@ data ConDeclField pass -- Record fields have Haddoc docs on them -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation -deriving instance (DataIdLR pass pass) => Data (ConDeclField pass) instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDeclField p) where @@ -1193,7 +1184,6 @@ data FieldOcc pass = FieldOcc { extFieldOcc :: XFieldOcc pass (XXFieldOcc pass) deriving instance (p ~ GhcPass pass, Eq (XFieldOcc p)) => Eq (FieldOcc p) deriving instance (p ~ GhcPass pass, Ord (XFieldOcc p)) => Ord (FieldOcc p) -deriving instance (DataId pass) => Data (FieldOcc pass) type instance XFieldOcc GhcPs = PlaceHolder type instance XFieldOcc GhcRn = Name @@ -1224,7 +1214,6 @@ data AmbiguousFieldOcc pass = Unambiguous (XUnambiguous pass) (Located RdrName) | Ambiguous (XAmbiguous pass) (Located RdrName) | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) -deriving instance DataId pass => Data (AmbiguousFieldOcc pass) type instance XUnambiguous GhcPs = PlaceHolder type instance XUnambiguous GhcRn = Name diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 756cdbf423..90e1ddbbe6 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -143,9 +143,9 @@ just attach noSrcSpan to everything. mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkHsPar e = L (getLoc e) (HsPar noExt e) -mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP id)) - -> [LPat id] -> Located (body id) - -> LMatch id (Located (body id)) +mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) + -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) + -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkSimpleMatch ctxt pats rhs = L loc $ Match { m_ctxt = ctxt, m_pats = pats @@ -155,7 +155,8 @@ mkSimpleMatch ctxt pats rhs [] -> getLoc rhs (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) -unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id)) +unguardedGRHSs :: Located (body (GhcPass p)) + -> GRHSs (GhcPass p) (Located (body (GhcPass p))) unguardedGRHSs rhs@(L loc _) = GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds) @@ -200,7 +201,8 @@ mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking -mkHsCaseAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id)) +mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p))) + -> LMatch (GhcPass p) (Located (body (GhcPass p))) mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr @@ -614,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 @@ -628,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 @@ -788,7 +791,7 @@ mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] mkFunBind fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup Generated ms , fun_co_fn = idHsWrapper - , bind_fvs = placeHolderNames + , fun_ext = noExt , fun_tick = [] } mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] @@ -797,22 +800,24 @@ mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] mkTopFunBind origin fn ms = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin ms , fun_co_fn = idHsWrapper - , bind_fvs = emptyNameSet -- NB: closed + , fun_ext = emptyNameSet -- NB: closed -- binding , fun_tick = [] } mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs -mkVarBind :: IdP p -> LHsExpr p -> LHsBind p +mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) mkVarBind var rhs = L (getLoc rhs) $ - VarBind { var_id = var, var_rhs = rhs, var_inline = False } + VarBind { var_ext = noExt, + var_id = var, var_rhs = rhs, var_inline = False } mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs -mkPatSynBind name details lpat dir = PatSynBind psb +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 @@ -821,7 +826,7 @@ mkPatSynBind name details lpat dir = PatSynBind psb -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is -- considered infix. isInfixFunBind :: HsBindLR id1 id2 -> Bool -isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _) +isInfixFunBind (FunBind _ _ (MG matches _ _ _) _ _) = any (isInfixMatch . unLoc) (unLoc matches) isInfixFunBind _ = False @@ -940,10 +945,11 @@ isBangedHsBind _ collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] -collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds +collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds -- No pattern synonyms here -collectLocalBinders (HsIPBinds _) = [] -collectLocalBinders EmptyLocalBinds = [] +collectLocalBinders (HsIPBinds {}) = [] +collectLocalBinders (EmptyLocalBinds _) = [] +collectLocalBinders (XHsLocalBindsLR _) = [] collectHsIdBinders, collectHsValBinders :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] @@ -983,9 +989,11 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ -- I don't think we want the binders from the abe_binds -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc +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] -- Used exclusively for the bindings of an instance decl which are all FunBinds @@ -1130,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 @@ -1153,14 +1162,14 @@ hsPatSynSelectors (XValBindsLR (NValBinds binds _)) addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] addPatSynSelector bind sels - | L _ (PatSynBind (PSB { psb_args = RecCon as })) <- bind + | L _ (PatSynBind _ (PSB { psb_args = RecCon as })) <- bind = map (unLoc . recordPatSynSelectorId) as ++ sels | otherwise = sels getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id] getPatSynBinds binds = [ psb | (_, lbinds) <- binds - , L _ (PatSynBind psb) <- bagToList lbinds ] + , L _ (PatSynBind _ psb) <- bagToList lbinds ] ------------------- hsLInstDeclBinders :: LInstDecl pass @@ -1285,9 +1294,10 @@ lStmtsImplicits = hs_lstmts hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss - hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds - hs_local_binds (HsIPBinds _) = emptyNameSet - hs_local_binds EmptyLocalBinds = emptyNameSet + hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds + hs_local_binds (HsIPBinds {}) = emptyNameSet + hs_local_binds (EmptyLocalBinds _) = emptyNameSet + hs_local_binds (XHsLocalBindsLR _) = emptyNameSet hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet hsValBindsImplicits (XValBindsLR (NValBinds binds _)) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 1012c25b28..db6f7f86ac 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -870,7 +870,7 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do -- create a new binding. let expr_fs = fsLit "_compileParsedExpr" expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc - let_stmt = L loc . LetStmt . L loc . HsValBinds $ + let_stmt = L loc . LetStmt . L loc . (HsValBinds noExt) $ ValBinds noExt (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index bbb75176bc..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 @@ -1572,15 +1572,13 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } -- No type declarations : decllist {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1) ; return (sL1 $1 (fst $ unLoc $1 - ,sL1 $1 $ HsValBinds val_binds)) } } + ,sL1 $1 $ HsValBinds noExt val_binds)) } } | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] - ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2) - emptyTcEvBinds)) } + ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) } | vocurly dbinds close { L (getLoc $2) ([] - ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2) - emptyTcEvBinds)) } + ,sL1 $2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc $2))) } wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) } @@ -2281,9 +2279,9 @@ decl_no_th :: { LHsDecl GhcPs } -- a FunBind or PatBind back from checkValDef. See Note -- [FunBind vs PatBind] case r of { - (FunBind n _ _ _ _) -> + (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]) ; @@ -2295,9 +2293,9 @@ decl_no_th :: { LHsDecl GhcPs } -- a FunBind or PatBind back from checkValDef. See Note -- [FunBind vs PatBind] case r of { - (FunBind n _ _ _ _) -> + (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 a976d08558..f3500014d1 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -100,6 +100,7 @@ import FastString import Maybes import Util import ApiAnnotation +import HsExtension ( noExt ) import Data.List import qualified GHC.LanguageExtensions as LangExt import MonadUtils @@ -560,7 +561,9 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = ; when (null matches) (wrongNumberErr loc) ; return $ mkMatchGroup FromSource matches } where - fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) = + fromDecl (L loc decl@(ValD (PatBind _ + pat@(L _ (ConPatIn ln@(L _ name) details)) + rhs _))) = do { unless (name == patsyn_name) $ wrongNameBindingErr loc decl ; match <- case details of @@ -1090,10 +1093,10 @@ makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too makeFunBind fn ms - = FunBind { fun_id = fn, + = FunBind { fun_ext = noExt, + fun_id = fn, fun_matches = mkMatchGroup FromSource ms, fun_co_fn = idHsWrapper, - bind_fvs = placeHolderNames, fun_tick = [] } checkPatBind :: SDoc @@ -1102,7 +1105,7 @@ checkPatBind :: SDoc -> P ([AddAnn],HsBind GhcPs) checkPatBind msg lhs (L _ (_,grhss)) = do { lhs <- checkPattern msg lhs - ; return ([],PatBind lhs grhss placeHolderType placeHolderNames + ; return ([],PatBind noExt lhs grhss ([],[])) } checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index c54c734dce..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 @@ -203,27 +202,31 @@ rnLocalBindsAndThen :: HsLocalBinds GhcPs -- This version (a) assumes that the binding vars are *not* already in scope -- (b) removes the binders from the free vars of the thing inside -- The parser doesn't produce ThenBinds -rnLocalBindsAndThen EmptyLocalBinds thing_inside = - thing_inside EmptyLocalBinds emptyNameSet +rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside = + thing_inside (EmptyLocalBinds x) emptyNameSet -rnLocalBindsAndThen (HsValBinds val_binds) thing_inside +rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside = rnLocalValBindsAndThen val_binds $ \ val_binds' -> - thing_inside (HsValBinds val_binds') + thing_inside (HsValBinds x val_binds') -rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do +rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do (binds',fv_binds) <- rnIPBinds binds - (thing, fvs_thing) <- thing_inside (HsIPBinds binds') fv_binds + (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds return (thing, fvs_thing `plusFV` fv_binds) +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" {- ************************************************************************ @@ -338,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 @@ -405,27 +408,27 @@ rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) = do -- we don't actually use the FV processing of rnPatsAndThen here (pat',pat'_fvs) <- rnBindPat name_maker pat - return (bind { pat_lhs = pat', bind_fvs = pat'_fvs }) + return (bind { pat_lhs = pat', pat_ext = pat'_fvs }) -- We temporarily store the pat's FVs in bind_fvs; -- gets updated to the FVs of the whole bind -- when doing the RHS below rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) = do { name <- applyNameMaker name_maker rdr_name - ; return (bind { fun_id = name - , bind_fvs = placeHolderNamesTc }) } + ; return (bind { fun_id = name + , fun_ext = noExt }) } -rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname }) +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 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 psb{ psb_id = name }) } + ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) } where localPatternSynonymErr :: SDoc localPatternSynonymErr @@ -450,7 +453,7 @@ rnBind _ bind@(PatBind { pat_lhs = pat , pat_rhs = grhss -- pat fvs were stored in bind_fvs -- after processing the LHS - , bind_fvs = pat_fvs }) + , pat_ext = pat_fvs }) = do { mod <- getModule ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss @@ -462,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, bind_fvs = fvs' } + , pat_ext = fvs' } ok_nobind_pat = -- See Note [Pattern bindings that bind no variables] @@ -501,13 +504,13 @@ rnBind sig_fn bind@(FunBind { fun_id = name ; fvs' `seq` -- See Note [Free-variable space leak] return (bind { fun_matches = matches' - , bind_fvs = fvs' }, + , fun_ext = fvs' }, [plain_name], rhs_fvs) } -rnBind sig_fn (PatSynBind bind) +rnBind sig_fn (PatSynBind x bind) = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind - ; return (PatSynBind bind', name, fvs) } + ; return (PatSynBind x bind', name, fvs) } rnBind _ b = pprPanic "rnBind" (ppr b) @@ -591,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 @@ -610,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 @@ -701,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' } @@ -723,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -876,9 +883,7 @@ rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest = setSrcSpan loc $ do do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name -- We use the selector name as the binder - ; let bind' = bind { fun_id = sel_name - , bind_fvs = placeHolderNamesTc } - + ; let bind' = bind { fun_id = sel_name, fun_ext = noExt } ; return (L loc bind' `consBag` rest ) } -- Report error for all other forms of bindings @@ -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 ec2b09f80d..4fe4102891 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -1099,10 +1099,10 @@ rnRecStmtsAndThen rnBody s cont 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 + (L _ (LetStmt (L _ (HsValBinds _ (ValBinds _ _ sigs))))) -> + foldr (\ sig -> \ acc -> case sig of + (L loc (FixSig _ s)) -> (L loc s) : acc + _ -> acc) acc sigs _ -> acc) [] l -- left-hand sides @@ -1127,12 +1127,12 @@ rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t)) return [(L loc (BindStmt pat' body a b t), fv_pat)] -rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _)))) +rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds {})))) = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds)))) +rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds x binds)))) = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds - return [(L loc (LetStmt (L l (HsValBinds binds'))), + return [(L loc (LetStmt (L l (HsValBinds x binds'))), -- Warning: this is bogus; see function invariant emptyFVs )] @@ -1150,8 +1150,10 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet = pprPanic "rn_rec_stmt" (ppr stmt) -rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds))) +rn_rec_stmt_lhs _ (L _ (LetStmt (L _ (EmptyLocalBinds _)))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" +rn_rec_stmt_lhs _ (L _ (LetStmt (L _ (XHsLocalBindsLR _)))) + = panic "rn_rec_stmt LetStmt XHsLocalBindsLR" rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv -> [LStmt GhcPs body] @@ -1202,15 +1204,15 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat) ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, L loc (BindStmt pat' body' bind_op fail_op placeHolder))] } -rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _) +rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds {}))), _) = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _) +rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds x binds'))), _) = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' -- fixities and unused are handled above in rnRecStmtsAndThen ; let fvs = allUses du_binds ; return [(duDefs du_binds, fvs, emptyNameSet, - L loc (LetStmt (L l (HsValBinds binds'))))] } + L loc (LetStmt (L l (HsValBinds x binds'))))] } -- no RecStmt case because they get flattened above when doing the LHSes rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _) @@ -1222,7 +1224,10 @@ 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 _ EmptyLocalBinds)), _) +rn_rec_stmt _ _ (L _ (LetStmt (L _ (XHsLocalBindsLR _))), _) + = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR" + +rn_rec_stmt _ _ (L _ (LetStmt (L _ (EmptyLocalBinds _))), _) = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) 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 31caffee80..07dcff2a04 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -580,7 +580,7 @@ checkCanonicalInstances cls poly_ty mbinds = do isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]} | GRHSs [L _ (GRHS [] body)] lbinds <- grhss - , L _ EmptyLocalBinds <- lbinds + , L _ (EmptyLocalBinds _) <- lbinds , L _ (HsVar _ (L _ rhsName)) <- body = Just rhsName isAliasMG _ = Nothing @@ -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 @@ -2011,8 +2011,8 @@ extendPatSynEnv val_decls local_fix_env thing = do { -> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])] new_ps' bind names - | L bind_loc (PatSynBind (PSB { psb_id = L _ n - , psb_args = RecCon as })) <- bind + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n + , psb_args = RecCon as })) <- bind = do bnd_name <- newTopSrcBinder (L bind_loc n) let rnames = map recordPatSynSelectorId as @@ -2021,7 +2021,7 @@ extendPatSynEnv val_decls local_fix_env thing = do { field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs return ((bnd_name, flds): names) - | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind = do bnd_name <- newTopSrcBinder (L bind_loc n) return ((bnd_name, []): names) @@ -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 f62ceb5065..5355cc9dbf 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 @@ -337,16 +337,16 @@ badBootDeclErr = text "Illegal declarations in an hs-boot file" tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTcId, thing) -tcLocalBinds EmptyLocalBinds thing_inside +tcLocalBinds (EmptyLocalBinds x) thing_inside = do { thing <- thing_inside - ; return (EmptyLocalBinds, thing) } + ; return (EmptyLocalBinds x, thing) } -tcLocalBinds (HsValBinds (XValBindsLR (NValBinds binds sigs))) thing_inside +tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside - ; return (HsValBinds (XValBindsLR (NValBinds binds' sigs)), thing) } -tcLocalBinds (HsValBinds (ValBinds {})) _ = panic "tcLocalBinds" + ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) } +tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds" -tcLocalBinds (HsIPBinds (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,27 +357,31 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside ; (ev_binds, result) <- checkConstraints (IPSkol ips) [] given_ips thing_inside - ; return (HsIPBinds (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 (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds" +tcLocalBinds (XHsLocalBindsLR _) _ = panic "tcLocalBinds" + {- Note [Implicit parameter untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We add the type variables in the types of the implicit parameters @@ -531,7 +535,7 @@ tc_single :: forall thing. -> LHsBind GhcRn -> IsGroupClosed -> TcM thing -> TcM (LHsBinds GhcTcId, thing) tc_single _top_lvl sig_fn _prag_fn - (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) + (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name })) _ thing_inside = do { (aux_binds, tcg_env) <- tc_pat_syn_decl ; thing <- setGblEnv tcg_env thing_inside @@ -566,6 +570,10 @@ mkEdges sig_fn binds -- is still deterministic even if the edges are in nondeterministic order -- as explained in Note [Deterministic SCC] in Digraph. where + bind_fvs (FunBind { fun_ext = fvs }) = fvs + bind_fvs (PatBind { pat_ext = fvs }) = fvs + bind_fvs _ = emptyNameSet + no_sig :: Name -> Bool no_sig n = not (hasCompleteSig sig_fn n) @@ -717,16 +725,18 @@ tcPolyCheck prag_fn ; let bind' = FunBind { fun_id = L nm_loc mono_id , fun_matches = matches' , fun_co_fn = co_fn - , bind_fvs = placeHolderNamesTc + , 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 } abs_bind = L loc $ - AbsBinds { abs_tvs = skol_tvs + AbsBinds { abs_ext = noExt + , abs_tvs = skol_tvs , abs_ev_vars = ev_vars , abs_ev_binds = [ev_binds] , abs_exports = [export] @@ -741,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 @@ -807,7 +817,8 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports abs_bind = L loc $ - AbsBinds { abs_tvs = qtvs + AbsBinds { abs_ext = noExt + , abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] , abs_exports = exports, abs_binds = binds' , abs_sig = False } @@ -867,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 @@ -1324,7 +1336,7 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur -> TcM (LHsBinds GhcTcId, [MonoBindInfo]) tcMonoBinds is_rec sig_fn no_gen [ L b_loc (FunBind { fun_id = L nm_loc name, - fun_matches = matches, bind_fvs = fvs })] + fun_matches = matches, fun_ext = fvs })] -- Single function binding, | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature @@ -1349,7 +1361,7 @@ tcMonoBinds is_rec sig_fn no_gen ; mono_id <- newLetBndr no_gen name rhs_ty ; return (unitBag $ L b_loc $ FunBind { fun_id = L nm_loc mono_id, - fun_matches = matches', bind_fvs = fvs, + fun_matches = matches', fun_ext = fvs, fun_co_fn = co_fn, fun_tick = [] }, [MBI { mbi_poly_name = name , mbi_sig = Nothing @@ -1497,7 +1509,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) ; return ( FunBind { fun_id = L loc mono_id , fun_matches = matches' , fun_co_fn = co_fn - , bind_fvs = placeHolderNamesTc + , fun_ext = placeHolderNamesTc , fun_tick = [] } ) } tcRhs (TcPatBind infos pat' grhss pat_ty) @@ -1510,8 +1522,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 - , bind_fvs = placeHolderNamesTc + , pat_ext = NPatBindTc placeHolderNamesTc pat_ty , pat_ticks = ([],[]) } )} tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a @@ -1775,16 +1786,18 @@ isClosedBndrGroup type_env binds fv_env :: NameEnv NameSet fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds - bindFvs :: HsBindLR GhcRn idR -> [(Name, NameSet)] - bindFvs (FunBind { fun_id = L _ f, bind_fvs = fvs }) - = let open_fvs = filterNameSet (not . is_closed) fvs + bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)] + bindFvs (FunBind { fun_id = L _ f, fun_ext = fvs }) + = let open_fvs = get_open_fvs fvs in [(f, open_fvs)] - bindFvs (PatBind { pat_lhs = pat, bind_fvs = fvs }) - = let open_fvs = filterNameSet (not . is_closed) fvs + bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs }) + = let open_fvs = get_open_fvs fvs in [(b, open_fvs) | b <- collectPatBinders pat] bindFvs _ = [] + get_open_fvs fvs = filterNameSet (not . is_closed) fvs + is_closed :: Name -> ClosedTypeId is_closed name | Just thing <- lookupNameEnv type_env name diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index dcc85af74d..118a219af6 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] @@ -287,11 +287,13 @@ 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 } - full_bind = AbsBinds { abs_tvs = tyvars + full_bind = AbsBinds { abs_ext = noExt + , abs_tvs = tyvars , abs_ev_vars = [this_dict] , abs_exports = [export] , abs_ev_binds = [ev_binds] @@ -358,8 +360,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 @@ -384,8 +386,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 e1d53aae5c..d3cbdb0f3c 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -663,8 +663,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 57549c67ef..05c6276cb5 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 14b19efa26..5be0087834 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -401,15 +401,15 @@ zonkTopDecls ev_binds binds rules vects imp_specs fords --------------------------------------------- zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId -> TcM (ZonkEnv, HsLocalBinds GhcTc) -zonkLocalBinds env EmptyLocalBinds - = return (env, EmptyLocalBinds) +zonkLocalBinds env (EmptyLocalBinds x) + = return (env, (EmptyLocalBinds x)) -zonkLocalBinds _ (HsValBinds (ValBinds {})) +zonkLocalBinds _ (HsValBinds _ (ValBinds {})) = panic "zonkLocalBinds" -- Not in typechecker output -zonkLocalBinds env (HsValBinds (XValBindsLR (NValBinds binds sigs))) +zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) = do { (env1, new_binds) <- go env binds - ; return (env1, HsValBinds (XValBindsLR (NValBinds new_binds sigs))) } + ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } where go env [] = return (env, []) @@ -418,17 +418,24 @@ zonkLocalBinds env (HsValBinds (XValBindsLR (NValBinds binds sigs))) ; (env2, bs') <- go env1 bs ; return (env2, (r,b'):bs') } -zonkLocalBinds env (HsIPBinds (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 (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 --------------------------------------------- zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc) @@ -446,16 +453,22 @@ 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_id = var, var_rhs = expr, var_inline = inl }) +zonk_bind env (VarBind { var_ext = x + , var_id = var, var_rhs = expr, var_inline = inl }) = do { new_var <- zonkIdBndr env var ; new_expr <- zonkLExpr env expr - ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) } + ; return (VarBind { var_ext = x + , var_id = new_var + , var_rhs = new_expr + , var_inline = inl }) } zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms , fun_co_fn = co_fn }) @@ -480,7 +493,8 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds ; new_exports <- mapM (zonk_export env3) exports ; return (new_val_binds, new_exports) } - ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs + ; return (AbsBinds { abs_ext = noExt + , abs_tvs = new_tyvars, abs_ev_vars = new_evs , abs_ev_binds = new_ev_binds , abs_exports = new_exports, abs_binds = new_val_bind , abs_sig = has_sig }) } @@ -502,32 +516,38 @@ 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 bind@(PSB { psb_id = L loc id - , psb_args = details - , psb_def = lpat - , psb_dir = dir })) +zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id + , psb_args = details + , psb_def = lpat + , psb_dir = dir })) = do { id' <- zonkIdBndr env id ; (env1, lpat') <- zonkPat env lpat ; let details' = zonkPatSynDetails env1 details ; (_env2, dir') <- zonkPatSynDir env1 dir - ; return $ PatSynBind $ + ; return $ PatSynBind x $ bind { psb_id = L loc id' , psb_args = details' , psb_def = lpat' , psb_dir = dir' } } +zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind" +zonk_bind _ (XHsBindsLR _) = panic "zonk_bind" + zonkPatSynDetails :: ZonkEnv -> HsPatSynDetails (Located TcId) -> HsPatSynDetails (Located Id) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 5bbcb4a46c..fb2e3452e9 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -890,12 +890,14 @@ 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 } -- NB: see Note [SPECIALISE instance pragmas] - main_bind = AbsBinds { abs_tvs = inst_tyvars + main_bind = AbsBinds { abs_ext = noExt + , abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] , abs_ev_binds = [] @@ -1039,12 +1041,14 @@ 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 } local_ev_binds = TcEvBinds ev_binds_var - bind = AbsBinds { abs_tvs = tyvars + bind = AbsBinds { abs_ext = noExt + , abs_tvs = tyvars , abs_ev_vars = dfun_evs , abs_exports = [export] , abs_ev_binds = [dfun_ev_binds, local_ev_binds] @@ -1382,13 +1386,15 @@ 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 } local_ev_binds = TcEvBinds ev_binds_var - full_bind = AbsBinds { abs_tvs = tyvars + full_bind = AbsBinds { abs_ext = noExt + , abs_tvs = tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] , abs_ev_binds = [dfun_ev_binds, local_ev_binds] @@ -1430,13 +1436,14 @@ 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 } ; return (unitBag $ L (getLoc meth_bind) $ - AbsBinds { abs_tvs = [], abs_ev_vars = [] + AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = [] , abs_exports = [export] , abs_binds = tc_bind, abs_ev_binds = [] , abs_sig = True }) } @@ -1582,7 +1589,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 @@ -1805,7 +1812,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 a4d796692f..a759716d71 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -687,7 +689,7 @@ tcPatSynMatcher (L loc name) lpat match = mkMatch (mkPrefixFunRhs (L loc name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') - (noLoc EmptyLocalBinds) + (noLoc (EmptyLocalBinds noExt)) mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg = MG{ mg_alts = L (getLoc match) [match] , mg_arg_tys = [] @@ -695,10 +697,10 @@ tcPatSynMatcher (L loc name) lpat , mg_origin = Generated } - ; let bind = FunBind{ fun_id = L loc matcher_id + ; let bind = FunBind{ fun_ext = emptyNameSet + , fun_id = L loc matcher_id , fun_matches = mg , fun_co_fn = idHsWrapper - , bind_fvs = emptyNameSet , fun_tick = [] } matcher_bind = unitBag (noLoc bind) @@ -780,10 +782,10 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat match_group' | need_dummy_arg = add_dummy_arg match_group | otherwise = match_group - bind = FunBind { fun_id = L loc (idName builder_id) + bind = FunBind { fun_ext = placeHolderNamesTc + , fun_id = L loc (idName builder_id) , fun_matches = match_group' , fun_co_fn = idHsWrapper - , bind_fvs = placeHolderNamesTc , fun_tick = [] } sig = completeSigFromId (PatSynCtxt name) builder_id @@ -808,7 +810,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat builder_args = [L loc (VarPat noExt (L loc n)) | L loc n <- args] builder_match = mkMatch (mkPrefixFunRhs (L loc name)) builder_args body - (noLoc EmptyLocalBinds) + (noLoc (EmptyLocalBinds noExt)) args = case details of PrefixCon args -> args @@ -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/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 76827fed0b..70348d3b59 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1988,13 +1988,15 @@ tcUserStmt (L loc (BodyStmt expr _ _ _)) matches = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr (noLoc emptyLocalBinds)] -- [it = expr] - the_bind = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs } + the_bind = L loc $ (mkTopFunBind FromSource + (L loc fresh_it) matches) { fun_ext = fvs } -- Care here! In GHCi the expression might have -- free variables, and they in turn may have free type variables -- (if we are at a breakpoint, say). We must put those free vars -- [let it = expr] - let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds $ XValBindsLR + let_stmt = L loc $ LetStmt $ noLoc $ HsValBinds noExt + $ XValBindsLR (NValBinds [(NonRecursive,unitBag the_bind)] []) -- [it <- e] diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index e07ff7c599..8624735169 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -181,20 +181,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 ] @@ -496,10 +496,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 @@ -532,7 +535,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 () @@ -684,7 +687,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 @@ -740,8 +743,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 0435dda331..4363cd3f5c 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -699,8 +699,9 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM kc_sig) sigs } where - kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType (TyConSkol ClassFlavour name) nms op_ty - kc_sig _ = return () + kc_sig (ClassOpSig _ _ nms op_ty) + = kcHsSigType (TyConSkol ClassFlavour name) 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 diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 68ae331fba..100b420227 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -203,6 +203,7 @@ ,({ DumpParsedAst.hs:11:1-23 } (ValD (FunBind + (PlaceHolder) ({ DumpParsedAst.hs:11:1-4 } (Unqual {OccName: main})) @@ -238,12 +239,12 @@ "\"hello\"") {FastString: "hello"})))))))] ({ <no location info> } - (EmptyLocalBinds)))))]) + (EmptyLocalBinds + (PlaceHolder))))))]) [] (PlaceHolder) (FromSource)) (WpHole) - (PlaceHolder) [])))] (Nothing) (Nothing))) diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 9d6cc6e953..cd6bd9823b 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -11,6 +11,8 @@ {Bag(Located (HsBind Name)): [({ DumpRenamedAst.hs:18:1-23 } (FunBind + {NameSet: + []} ({ DumpRenamedAst.hs:18:1-4 } {Name: DumpRenamedAst.main}) (MG @@ -43,13 +45,12 @@ "\"hello\"") {FastString: "hello"})))))))] ({ <no location info> } - (EmptyLocalBinds)))))]) + (EmptyLocalBinds + (PlaceHolder))))))]) [] (PlaceHolder) (FromSource)) (WpHole) - {NameSet: - []} []))]})] [])) [] diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index b888067af1..02f0e3c099 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -4,6 +4,7 @@ {Bag(Located (HsBind Var)): [({ <no location info> } (VarBind + (PlaceHolder) {Var: DumpTypecheckedAst.$tcPeano} ({ <no location info> } (HsApp @@ -69,6 +70,7 @@ (False))) ,({ <no location info> } (VarBind + (PlaceHolder) {Var: DumpTypecheckedAst.$tc'Zero} ({ <no location info> } (HsApp @@ -134,6 +136,7 @@ (False))) ,({ <no location info> } (VarBind + (PlaceHolder) {Var: DumpTypecheckedAst.$tc'Succ} ({ <no location info> } (HsApp @@ -199,6 +202,7 @@ (False))) ,({ <no location info> } (VarBind + (PlaceHolder) {Var: $krep} ({ <no location info> } (HsApp @@ -223,6 +227,7 @@ (False))) ,({ <no location info> } (VarBind + (PlaceHolder) {Var: $krep} ({ <no location info> } (HsApp @@ -252,6 +257,7 @@ (False))) ,({ <no location info> } (VarBind + (PlaceHolder) {Var: DumpTypecheckedAst.$trModule} ({ <no location info> } (HsApp @@ -298,9 +304,11 @@ (False))) ,({ DumpTypecheckedAst.hs:11:1-23 } (AbsBinds + (PlaceHolder) [] [] [(ABE + (PlaceHolder) {Var: main} {Var: main} (WpHole) @@ -310,6 +318,8 @@ {Bag(Located (HsBind Var)): [({ DumpTypecheckedAst.hs:11:1-23 } (FunBind + {NameSet: + []} ({ DumpTypecheckedAst.hs:11:1-4 } {Var: main}) (MG @@ -342,7 +352,8 @@ "\"hello\"") {FastString: "hello"})))))))] ({ <no location info> } - (EmptyLocalBinds)))))]) + (EmptyLocalBinds + (PlaceHolder))))))]) [] (TyConApp ({abstract:TyCon}) @@ -351,8 +362,6 @@ [])]) (FromSource)) (WpHole) - {NameSet: - []} []))]} (False)))]} diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index 21d9e18245..1a3d21c7a8 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -10,7 +10,7 @@ test('haddock.base', # 2017-02-19 24286343184 (x64/Windows) - Generalize kind of (->) # 2017-12-24 18733710728 (x64/Windows) - Unknown - ,(wordsize(64), 20980255200, 5) + ,(wordsize(64), 18511324808, 5) # 2012-08-14: 5920822352 (amd64/Linux) # 2012-09-20: 5829972376 (amd64/Linux) # 2012-10-08: 5902601224 (amd64/Linux) @@ -47,6 +47,7 @@ test('haddock.base', # 2018-03-31: 20980255200 (x86_64/Linux) - Track type variable scope more carefully # previous to this last commit, the allocations were right below the top # of the range. This commit adds only ~1.5% allocations. + # 2018-04-10: 18511324808 (x86_64/Linux) - TTG HsBinds and Data instances ,(platform('i386-unknown-mingw32'), 2885173512, 5) # 2013-02-10: 3358693084 (x86/Windows) @@ -73,7 +74,7 @@ test('haddock.Cabal', [extra_files(['../../../../libraries/Cabal/Cabal/dist-install/haddock.t']), unless(in_tree_compiler(), skip), req_haddock ,stats_num_field('bytes allocated', - [(wordsize(64), 25261834904, 5) + [(wordsize(64), 23525241536, 5) # 2012-08-14: 3255435248 (amd64/Linux) # 2012-08-29: 3324606664 (amd64/Linux, new codegen) # 2012-10-08: 3373401360 (amd64/Linux) @@ -126,6 +127,7 @@ test('haddock.Cabal', # 2017-11-06: 18936339648 (amd64/Linux) - Unknown # 2017-11-09: 20104611952 (amd64/Linux) - Bump Cabal # 2018-01-22: 25261834904 (amd64/Linux) - Bump Cabal + # 2018-04-10: 23525241536 (amd64/Linux) - TTG HsBinds and Data instances ,(platform('i386-unknown-mingw32'), 3293415576, 5) # 2012-10-30: 1733638168 (x86/Windows) @@ -151,7 +153,7 @@ test('haddock.compiler', ,stats_num_field('bytes allocated', [(platform('x86_64-unknown-mingw32'), 56775301896, 10), # 2017-12-24: 56775301896 (x64/Windows) - (wordsize(64), 91115212032, 10) + (wordsize(64), 58410358720, 10) # 2012-08-14: 26070600504 (amd64/Linux) # 2012-08-29: 26353100288 (amd64/Linux, new CG) # 2012-09-18: 26882813032 (amd64/Linux) @@ -174,6 +176,7 @@ test('haddock.compiler', # 2017-06-06: 55990521024 (amd64/Linux) Don't pass on -dcore-lint in Haddock.mk # 2017-07-12: 51592019560 (amd64/Linux) Use getNameToInstancesIndex # 2018-04-08: 91115212032 (amd64/Linux) Trees that grow + # 2018-04-10: 58410358720 (amd64/Linux) Trees that grow (HsBinds, Data instances) ,(platform('i386-unknown-mingw32'), 367546388, 10) # 2012-10-30: 13773051312 (x86/Windows) diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 059692622e..5e96f35e74 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -284,7 +284,9 @@ boundThings modname lbinding = PatBind { pat_lhs = lhs } -> patThings lhs [] VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)] AbsBinds { } -> [] -- nothing interesting in a type abstraction - PatSynBind PSB{ psb_id = id } -> [thing id] + PatSynBind _ PSB{ psb_id = id } -> [thing id] + PatSynBind _ (XPatSynBind _) -> [] + XHsBindsLR _ -> [] where thing = foundOfLName modname patThings lpat tl = let loc = startOfLocated lpat diff --git a/utils/haddock b/utils/haddock -Subproject c84939c8428a9e9ae0753e75ca6b48fcbbc1ecd +Subproject a8ca2ae8737d29145fe57a7709e59be8cb7a00d |