diff options
Diffstat (limited to 'compiler/hsSyn/HsDecls.hs')
-rw-r--r-- | compiler/hsSyn/HsDecls.hs | 85 |
1 files changed, 52 insertions, 33 deletions
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 55f3b73686..0ff36aa712 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -48,7 +48,7 @@ module HsDecls ( -- ** Deriving strategies DerivStrategy(..), LDerivStrategy, derivStrategyName, -- ** @RULE@ declarations - LRuleDecls,RuleDecls(..),RuleDecl(..), LRuleDecl, HsRuleRn(..), + LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, flattenRuleDecls, pprFullRuleName, @@ -1528,9 +1528,12 @@ type HsTyPats pass = [LHsType pass] {- Note [Family instance declaration binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For ordinary data/type family instances, the feqn_pats field of FamEqn stores -the LHS type (and kind) patterns. These type patterns can of course contain -type (and kind) variables, which are bound in the hsib_vars field of the -HsImplicitBndrs in FamInstEqn. Note in particular +the LHS type (and kind) patterns. Any type (and kind) variables contained +in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs +in FamInstEqn depending on whether or not an explicit forall is present. In +the case of an explicit forall, the hsib_vars only includes kind variables not +bound in the forall. Otherwise, all type (and kind) variables are bound in +the hsib_vars. In the latter case, note that in particular * The hsib_vars *includes* any anonymous wildcards. For example type instance F a _ = a @@ -1616,6 +1619,7 @@ data FamEqn pass pats rhs = FamEqn { feqn_ext :: XCFamEqn pass pats rhs , feqn_tycon :: Located (IdP pass) + , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars , feqn_pats :: pats , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration , feqn_rhs :: rhs @@ -1701,10 +1705,11 @@ ppr_instance_keyword NotTopLevel = empty ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p)) => TyFamInstEqn (GhcPass p) -> SDoc ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = tycon + , feqn_bndrs = bndrs , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = rhs }}) - = pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs + = pprFamInstLHS tycon bndrs pats fixity [] Nothing <+> equals <+> ppr rhs ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x @@ -1726,13 +1731,14 @@ pprDataFamInstDecl :: (OutputableBndrId (GhcPass p)) => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = tycon + , feqn_bndrs = bndrs , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = defn }}}) = pp_data_defn pp_hdr defn where pp_hdr ctxt = ppr_instance_keyword top_lvl - <+> pprFamInstLHS tycon pats fixity ctxt Nothing + <+> pprFamInstLHS tycon bndrs pats fixity ctxt Nothing -- No need to pass an explicit kind signature to -- pprFamInstLHS here, since pp_data_defn already -- pretty-prints that. See #14817. @@ -1755,14 +1761,16 @@ pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x)) pprFamInstLHS :: (OutputableBndrId (GhcPass p)) => Located (IdP (GhcPass p)) + -> Maybe [LHsTyVarBndr (GhcPass p)] -> HsTyPats (GhcPass p) -> LexicalFixity -> HsContext (GhcPass p) -> Maybe (LHsKind (GhcPass p)) -> SDoc -pprFamInstLHS thing typats fixity context mb_kind_sig +pprFamInstLHS thing bndrs typats fixity context mb_kind_sig -- explicit type patterns - = hsep [ pprHsContext context, pp_pats typats, pp_kind_sig ] + = hsep [ pprHsContext context, pprHsExplicitForAll bndrs + , pp_pats typats, pp_kind_sig ] where pp_pats (patl:patr:pats) | Infix <- fixity @@ -2139,24 +2147,27 @@ type LRuleDecl pass = Located (RuleDecl pass) -- | Rule Declaration data RuleDecl pass - = HsRule -- Source rule - (XHsRule pass) -- After renamer, free-vars from the LHS and RHS - (Located (SourceText,RuleName)) -- Rule name - -- Note [Pragma source text] in BasicTypes - Activation - [LRuleBndr pass] -- Forall'd vars; after typechecking this - -- includes tyvars - (Located (HsExpr pass)) -- LHS - (Located (HsExpr pass)) -- RHS - -- ^ - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', - -- 'ApiAnnotation.AnnVal', - -- 'ApiAnnotation.AnnClose', - -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot', - -- 'ApiAnnotation.AnnEqual', - - -- For details on above see note [Api annotations] in ApiAnnotation + = HsRule -- Source rule + { rd_ext :: XHsRule pass + -- ^ After renamer, free-vars from the LHS and RHS + , rd_name :: Located (SourceText,RuleName) + -- ^ Note [Pragma source text] in BasicTypes + , rd_act :: Activation + , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] + -- ^ Forall'd type vars + , rd_tmvs :: [LRuleBndr pass] + -- ^ Forall'd term vars, before typechecking; after typechecking + -- this includes all forall'd vars + , rd_lhs :: Located (HsExpr pass) + , rd_rhs :: Located (HsExpr pass) + } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot', + -- 'ApiAnnotation.AnnEqual', | XRuleDecl (XXRuleDecl pass) data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS @@ -2195,21 +2206,29 @@ collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (RuleDecls p) where - ppr (HsRules _ st rules) +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecls p) where + ppr (HsRules { rds_src = st + , rds_rules = rules }) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" ppr (XRuleDecls x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where - ppr (HsRule _ name act ns lhs rhs) + ppr (HsRule { rd_name = name + , rd_act = act + , rd_tyvs = tys + , rd_tmvs = tms + , rd_lhs = lhs + , rd_rhs = rhs }) = sep [pprFullRuleName name <+> ppr act, - nest 4 (pp_forall <+> pprExpr (unLoc lhs)), + nest 4 (pp_forall_ty tys <+> pp_forall_tm tys + <+> pprExpr (unLoc lhs)), nest 6 (equals <+> pprExpr (unLoc rhs)) ] where - pp_forall | null ns = empty - | otherwise = forAllLit <+> fsep (map ppr ns) <> dot + pp_forall_ty Nothing = empty + pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot + pp_forall_tm Nothing | null tms = empty + pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot ppr (XRuleDecl x) = ppr x instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where |