diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2019-10-25 11:20:48 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-10-28 09:22:35 -0400 |
commit | e951f219597a3e8209abd62f85c717865f7445ca (patch) | |
tree | f1036c6a31758fb835179fc147ab4830c0b61c20 /compiler/GHC | |
parent | e0e0485634d9a047b43da958c09e3bf6c5937c0f (diff) | |
download | haskell-e951f219597a3e8209abd62f85c717865f7445ca.tar.gz |
Use FlexibleInstances for `Outputable (* p)` instead of match-all instances with equality constraints
In #17304, Richard and Simon dicovered that using `-XFlexibleInstances`
for `Outputable` instances of AST data types means users can provide orphan
`Outputable` instances for passes other than `GhcPass`.
Type inference doesn't currently to suffer, and Richard gave an example
in #17304 that shows how rare a case would be where the slightly worse
type inference would matter.
So I went ahead with the refactoring, attempting to fix #17304.
Diffstat (limited to 'compiler/GHC')
-rw-r--r-- | compiler/GHC/Hs.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Hs/Binds.hs | 48 | ||||
-rw-r--r-- | compiler/GHC/Hs/Decls.hs | 107 | ||||
-rw-r--r-- | compiler/GHC/Hs/Expr.hs | 114 | ||||
-rw-r--r-- | compiler/GHC/Hs/Expr.hs-boot | 19 | ||||
-rw-r--r-- | compiler/GHC/Hs/Extension.hs | 18 | ||||
-rw-r--r-- | compiler/GHC/Hs/ImpExp.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Hs/Lit.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Hs/Pat.hs | 14 | ||||
-rw-r--r-- | compiler/GHC/Hs/Pat.hs-boot | 3 | ||||
-rw-r--r-- | compiler/GHC/Hs/Types.hs | 52 |
11 files changed, 197 insertions, 194 deletions
diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index aa345f1476..103539a41b 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -118,7 +118,7 @@ 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 +instance (OutputableBndrId p) => Outputable (HsModule (GhcPass p)) where ppr (HsModule Nothing _ imports decls _ mbDoc) = pp_mb mbDoc $$ pp_nonnull imports diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 01c10b1ea1..3089f042a7 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -11,6 +11,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} @@ -617,17 +618,15 @@ Specifically, it's just an error thunk -} -instance (idL ~ GhcPass pl, idR ~ GhcPass pr, - OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsLocalBindsLR idL idR) where +instance (OutputableBndrId pl, OutputableBndrId pr) + => Outputable (HsLocalBindsLR (GhcPass pl) (GhcPass pr)) where 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) - => Outputable (HsValBindsLR idL idR) where +instance (OutputableBndrId pl, OutputableBndrId pr) + => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where ppr (ValBinds _ binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) @@ -642,15 +641,15 @@ instance (idL ~ GhcPass pl, idR ~ GhcPass pr, pp_rec Recursive = text "rec" pp_rec NonRecursive = text "nonrec" -pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) +pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR) => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = pprDeclList (map ppr (bagToList binds)) -pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), - OutputableBndrId (GhcPass id2)) +pprLHsBindsForUser :: (OutputableBndrId idL, + OutputableBndrId idR, + OutputableBndrId id2) => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] -- pprLHsBindsForUser is different to pprLHsBinds because -- a) No braces: 'let' and 'where' include a list of HsBindGroups @@ -725,12 +724,11 @@ plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) plusHsValBinds _ _ = panic "HsBinds.plusHsValBinds" -instance (idL ~ GhcPass pl, idR ~ GhcPass pr, - OutputableBndrId idL, OutputableBndrId idR) - => Outputable (HsBindLR idL idR) where +instance (OutputableBndrId pl, OutputableBndrId pr) + => Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) +ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR) => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) @@ -766,16 +764,16 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars pprLHsBinds val_binds ppr_monobind (XHsBindsLR x) = ppr x -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where +instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) = vcat [ ppr gbl <+> text "<=" <+> ppr lcl , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] ppr (XABExport x) = ppr x -instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR, - Outputable (XXPatSynBind idL idR)) - => Outputable (PatSynBind idL idR) where +instance (OutputableBndrId l, OutputableBndrId r, + Outputable (XXPatSynBind (GhcPass l) (GhcPass r))) + => Outputable (PatSynBind (GhcPass l) (GhcPass r)) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) = ppr_lhs <+> ppr_rhs @@ -866,13 +864,13 @@ data IPBind id type instance XCIPBind (GhcPass p) = NoExtField type instance XXIPBind (GhcPass p) = NoExtCon -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsIPBinds p) where +instance OutputableBndrId p + => Outputable (HsIPBinds (GhcPass p)) where 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 +instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of Left (L _ ip) -> pprBndr LetBind ip @@ -1168,10 +1166,10 @@ signatures. Since some of the signatures contain a list of names, testing for equality is not enough -- we have to check if they overlap. -} -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where +instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where ppr sig = ppr_sig sig -ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc +ppr_sig :: (OutputableBndrId p) => Sig (GhcPass p) -> SDoc 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) @@ -1204,8 +1202,8 @@ ppr_sig (CompleteMatchSig _ src cs mty) opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty ppr_sig (XSig x) = ppr x -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (FixitySig p) where +instance OutputableBndrId p + => Outputable (FixitySig (GhcPass p)) where ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] where pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index c43a27cef2..f095a3ffeb 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -7,6 +7,7 @@ DeriveTraversable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} @@ -274,7 +275,7 @@ appendGroups hs_docs = docs1 ++ docs2 } appendGroups _ _ = panic "appendGroups" -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where +instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where ppr (TyClD _ dcl) = ppr dcl ppr (ValD _ binds) = ppr binds ppr (DefD _ def) = ppr def @@ -291,7 +292,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where ppr (RoleAnnotD _ ra) = ppr ra ppr (XHsDecl x) = ppr x -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where +instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where ppr (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -340,8 +341,8 @@ data SpliceDecl p type instance XSpliceDecl (GhcPass _) = NoExtField type instance XXSpliceDecl (GhcPass _) = NoExtCon -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (SpliceDecl p) where +instance OutputableBndrId p + => Outputable (SpliceDecl (GhcPass p)) where ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f ppr (XSpliceDecl x) = ppr x @@ -707,7 +708,7 @@ hsDeclHasCusk (XTyClDecl nec) = noExtCon nec -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where +instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity @@ -740,8 +741,8 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where ppr (XTyClDecl x) = ppr x -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (TyClGroup p) where +instance OutputableBndrId p + => Outputable (TyClGroup (GhcPass p)) where ppr (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_kisigs = kisigs @@ -755,7 +756,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) ppr instds ppr (XTyClGroup x) = ppr x -pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p)) +pp_vanilla_decl_head :: (OutputableBndrId p) => Located (IdP (GhcPass p)) -> LHsQTyVars (GhcPass p) -> LexicalFixity @@ -1105,11 +1106,11 @@ resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a)) resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig resultVariableName _ = Nothing -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (FamilyDecl p) where +instance OutputableBndrId p + => Outputable (FamilyDecl (GhcPass p)) where ppr = pprFamilyDecl TopLevel -pprFamilyDecl :: (OutputableBndrId (GhcPass p)) +pprFamilyDecl :: (OutputableBndrId p) => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdTyVars = tyvars @@ -1238,8 +1239,8 @@ data HsDerivingClause pass type instance XCHsDerivingClause (GhcPass _) = NoExtField type instance XXHsDerivingClause (GhcPass _) = NoExtCon -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsDerivingClause p) where +instance OutputableBndrId p + => Outputable (HsDerivingClause (GhcPass p)) where ppr (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }) = hsep [ text "deriving" @@ -1439,7 +1440,7 @@ hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass] hsConDeclTheta Nothing = [] hsConDeclTheta (Just (L _ theta)) = theta -pp_data_defn :: (OutputableBndrId (GhcPass p)) +pp_data_defn :: (OutputableBndrId p) => (LHsContext (GhcPass p) -> SDoc) -- Printing the header -> HsDataDefn (GhcPass p) -> SDoc @@ -1464,12 +1465,12 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context pp_derivings (L _ ds) = vcat (map ppr ds) pp_data_defn _ (XHsDataDefn x) = ppr x -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsDataDefn p) where +instance OutputableBndrId p + => Outputable (HsDataDefn (GhcPass p)) where ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (StandaloneKindSig p) where +instance OutputableBndrId p + => Outputable (StandaloneKindSig (GhcPass p)) where ppr (StandaloneKindSig _ v ki) = text "type" <+> ppr v <+> text "::" <+> ppr ki ppr (XStandaloneKindSig nec) = noExtCon nec @@ -1477,16 +1478,16 @@ instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" -pp_condecls :: (OutputableBndrId (GhcPass p)) => [LConDecl (GhcPass p)] -> SDoc +pp_condecls :: (OutputableBndrId p) => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDecl p) where +instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where ppr = pprConDecl -pprConDecl :: (OutputableBndrId (GhcPass p)) => ConDecl (GhcPass p) -> SDoc +pprConDecl :: (OutputableBndrId p) => ConDecl (GhcPass p) -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_ex_tvs = ex_tvs , con_mb_cxt = mcxt @@ -1726,11 +1727,11 @@ type instance XDataFamInstD (GhcPass _) = NoExtField type instance XTyFamInstD (GhcPass _) = NoExtField type instance XXInstDecl (GhcPass _) = NoExtCon -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (TyFamInstDecl p) where +instance OutputableBndrId p + => Outputable (TyFamInstDecl (GhcPass p)) where ppr = pprTyFamInstDecl TopLevel -pprTyFamInstDecl :: (OutputableBndrId (GhcPass p)) +pprTyFamInstDecl :: (OutputableBndrId p) => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn @@ -1739,11 +1740,11 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty -pprTyFamDefltDecl :: (OutputableBndrId (GhcPass p)) +pprTyFamDefltDecl :: (OutputableBndrId p) => TyFamDefltDecl (GhcPass p) -> SDoc pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel -ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p)) +ppr_fam_inst_eqn :: (OutputableBndrId p) => TyFamInstEqn (GhcPass p) -> SDoc ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon , feqn_bndrs = bndrs @@ -1754,11 +1755,11 @@ ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (DataFamInstDecl p) where +instance OutputableBndrId p + => Outputable (DataFamInstDecl (GhcPass p)) where ppr = pprDataFamInstDecl TopLevel -pprDataFamInstDecl :: (OutputableBndrId (GhcPass p)) +pprDataFamInstDecl :: (OutputableBndrId p) => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon @@ -1789,7 +1790,7 @@ pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x))) pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x)) = ppr x -pprHsFamInstLHS :: (OutputableBndrId (GhcPass p)) +pprHsFamInstLHS :: (OutputableBndrId p) => IdP (GhcPass p) -> Maybe [LHsTyVarBndr (GhcPass p)] -> HsTyPats (GhcPass p) @@ -1811,8 +1812,8 @@ pprHsFamInstLHS thing bndrs typats fixity mb_ctxt pp_pats pats = hsep [ pprPrefixOcc thing , hsep (map ppr pats)] -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (ClsInstDecl p) where +instance OutputableBndrId p + => Outputable (ClsInstDecl (GhcPass p)) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap @@ -1831,8 +1832,8 @@ instance (p ~ GhcPass pass, OutputableBndrId p) <+> ppr inst_ty ppr (XClsInstDecl x) = ppr x -ppDerivStrategy :: (p ~ GhcPass pass, OutputableBndrId p) - => Maybe (LDerivStrategy p) -> SDoc +ppDerivStrategy :: OutputableBndrId p + => Maybe (LDerivStrategy (GhcPass p)) -> SDoc ppDerivStrategy mb = case mb of Nothing -> empty @@ -1852,7 +1853,7 @@ ppOverlapPragma mb = maybe_stext (SourceText src) _ = text src <+> text "#-}" -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where +instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl @@ -1911,8 +1912,8 @@ data DerivDecl pass = DerivDecl type instance XCDerivDecl (GhcPass _) = NoExtField type instance XXDerivDecl (GhcPass _) = NoExtCon -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (DerivDecl p) where +instance OutputableBndrId p + => Outputable (DerivDecl (GhcPass p)) where ppr (DerivDecl { deriv_type = ty , deriv_strategy = ds , deriv_overlap_mode = o }) @@ -1951,8 +1952,8 @@ type instance XViaStrategy GhcPs = LHsSigType GhcPs type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (DerivStrategy p) where +instance OutputableBndrId p + => Outputable (DerivStrategy (GhcPass p)) where ppr StockStrategy = text "stock" ppr AnyclassStrategy = text "anyclass" ppr NewtypeStrategy = text "newtype" @@ -2009,8 +2010,8 @@ data DefaultDecl pass type instance XCDefaultDecl (GhcPass _) = NoExtField type instance XXDefaultDecl (GhcPass _) = NoExtCon -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (DefaultDecl p) where +instance OutputableBndrId p + => Outputable (DefaultDecl (GhcPass p)) where ppr (DefaultDecl _ tys) = text "default" <+> parens (interpp'SP tys) ppr (XDefaultDecl x) = ppr x @@ -2117,8 +2118,8 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- pretty printing of foreign declarations -- -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (ForeignDecl p) where +instance OutputableBndrId p + => Outputable (ForeignDecl (GhcPass p)) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) = hang (text "foreign import" <+> ppr fimport <+> ppr n) 2 (dcolon <+> ppr ty) @@ -2244,14 +2245,14 @@ 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 +instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass 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 +instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where ppr (HsRule { rd_name = name , rd_act = act , rd_tyvs = tys @@ -2269,7 +2270,7 @@ instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot ppr (XRuleDecl x) = ppr x -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where +instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where ppr (RuleBndr _ name) = ppr name ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) ppr (XRuleBndr x) = ppr x @@ -2338,15 +2339,15 @@ type instance XWarning (GhcPass _) = NoExtField type instance XXWarnDecl (GhcPass _) = NoExtCon -instance (p ~ GhcPass pass,OutputableBndr (IdP p)) - => Outputable (WarnDecls p) where +instance OutputableBndr (IdP (GhcPass p)) + => Outputable (WarnDecls (GhcPass p)) where ppr (Warnings _ (SourceText src) decls) = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" ppr (XWarnDecls x) = ppr x -instance (p ~ GhcPass pass, OutputableBndr (IdP p)) - => Outputable (WarnDecl p) where +instance OutputableBndr (IdP (GhcPass p)) + => Outputable (WarnDecl (GhcPass p)) where ppr (Warning _ thing txt) = hsep ( punctuate comma (map ppr thing)) <+> ppr txt @@ -2379,7 +2380,7 @@ data AnnDecl pass = HsAnnotation type instance XHsAnnotation (GhcPass _) = NoExtField type instance XXAnnDecl (GhcPass _) = NoExtCon -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where +instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where ppr (HsAnnotation _ _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] ppr (XAnnDecl x) = ppr x @@ -2432,8 +2433,8 @@ data RoleAnnotDecl pass type instance XCRoleAnnotDecl (GhcPass _) = NoExtField type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon -instance (p ~ GhcPass pass, OutputableBndr (IdP p)) - => Outputable (RoleAnnotDecl p) where +instance OutputableBndr (IdP (GhcPass p)) + => Outputable (RoleAnnotDecl (GhcPass p)) where ppr (RoleAnnotDecl _ ltycon roles) = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+> hsep (map (pp_role . unLoc) roles) diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 91c532d2d9..7a9caa8c6e 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -6,6 +6,7 @@ {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} @@ -133,8 +134,8 @@ mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name -- don't care about filling in syn_arg_wraps because we're clearly -- not past the typechecker -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (SyntaxExpr p) where +instance OutputableBndrId p + => Outputable (SyntaxExpr (GhcPass p)) where ppr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -811,16 +812,16 @@ an empty ExplicitList when -XOverloadedLists. See also #13680, which requested [] @Int to work. -} -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) where +instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where ppr expr = pprExpr expr ----------------------- -- pprExpr, pprLExpr, pprBinds call pprDeeper; -- the underscore versions do not -pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc +pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc pprLExpr (L _ e) = pprExpr e -pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc +pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e | otherwise = pprDeeper (ppr_expr e) @@ -835,15 +836,15 @@ isQuietHsExpr (HsAppType {}) = True isQuietHsExpr (OpApp {}) = True isQuietHsExpr _ = False -pprBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) +pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- -ppr_lexpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc +ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc ppr_lexpr e = ppr_expr (unLoc e) -ppr_expr :: forall p. (OutputableBndrId (GhcPass p)) +ppr_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc uv @@ -1029,7 +1030,7 @@ ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) ppr_expr (HsRecFld _ f) = ppr f ppr_expr (XExpr x) = ppr x -ppr_infix_expr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> Maybe SDoc +ppr_infix_expr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) ppr_infix_expr (HsConLikeOut _ c) = Just (pprInfixOcc (conLikeName c)) ppr_infix_expr (HsRecFld _ f) = Just (pprInfixOcc f) @@ -1037,7 +1038,7 @@ ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ) ppr_infix_expr (HsWrap _ _ e) = ppr_infix_expr e ppr_infix_expr _ = Nothing -ppr_apps :: (OutputableBndrId (GhcPass p)) +ppr_apps :: (OutputableBndrId p) => HsExpr (GhcPass p) -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] -> SDoc @@ -1069,18 +1070,18 @@ fixities should do the job, except in debug mode (-dppr-debug) so we can see the structure of the parse tree. -} -pprDebugParendExpr :: (OutputableBndrId (GhcPass p)) +pprDebugParendExpr :: (OutputableBndrId p) => PprPrec -> LHsExpr (GhcPass p) -> SDoc pprDebugParendExpr p expr = getPprStyle (\sty -> if debugStyle sty then pprParendLExpr p expr else pprLExpr expr) -pprParendLExpr :: (OutputableBndrId (GhcPass p)) +pprParendLExpr :: (OutputableBndrId p) => PprPrec -> LHsExpr (GhcPass p) -> SDoc pprParendLExpr p (L _ e) = pprParendExpr p e -pprParendExpr :: (OutputableBndrId (GhcPass p)) +pprParendExpr :: (OutputableBndrId p) => PprPrec -> HsExpr (GhcPass p) -> SDoc pprParendExpr p expr | hsExprNeedsParens p expr = parens (pprExpr expr) @@ -1316,16 +1317,16 @@ type instance XCmdTop GhcTc = CmdTopTc type instance XXCmdTop (GhcPass _) = NoExtCon -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where +instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where ppr cmd = pprCmd cmd ----------------------- -- pprCmd and pprLCmd call pprDeeper; -- the underscore versions do not -pprLCmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc +pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc pprLCmd (L _ c) = pprCmd c -pprCmd :: (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc +pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc pprCmd c | isQuietHsCmd c = ppr_cmd c | otherwise = pprDeeper (ppr_cmd c) @@ -1339,10 +1340,10 @@ isQuietHsCmd (HsCmdApp {}) = True isQuietHsCmd _ = False ----------------------- -ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc +ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc ppr_lcmd c = ppr_cmd (unLoc c) -ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc +ppr_cmd :: forall p. (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp _ c e) @@ -1404,12 +1405,12 @@ ppr_cmd (HsCmdArrForm _ op _ _ args) 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") ppr_cmd (XCmd x) = ppr x -pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc +pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc pprCmdArg (HsCmdTop _ cmd) = ppr_lcmd cmd pprCmdArg (XCmdTop x) = ppr x -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where +instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where ppr = pprCmdArg {- @@ -1485,8 +1486,8 @@ data Match p body type instance XCMatch (GhcPass _) b = NoExtField type instance XXMatch (GhcPass _) b = NoExtCon -instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body) - => Outputable (Match idR body) where +instance (OutputableBndrId pr, Outputable body) + => Outputable (Match (GhcPass pr) body) where ppr = pprMatch {- @@ -1591,7 +1592,7 @@ type instance XXGRHS (GhcPass _) b = NoExtCon -- We know the list must have at least one @Match@ in it. -pprMatches :: (OutputableBndrId (GhcPass idR), Outputable body) +pprMatches :: (OutputableBndrId idR, Outputable body) => MatchGroup (GhcPass idR) body -> SDoc pprMatches MG { mg_alts = matches } = vcat (map pprMatch (map unLoc (unLoc matches))) @@ -1599,20 +1600,20 @@ pprMatches MG { mg_alts = matches } pprMatches (XMatchGroup x) = ppr x -- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body) +pprFunBind :: (OutputableBndrId idR, Outputable body) => MatchGroup (GhcPass idR) body -> SDoc pprFunBind matches = pprMatches matches -- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr), - OutputableBndrId (GhcPass p), +pprPatBind :: forall bndr p body. (OutputableBndrId bndr, + OutputableBndrId p, Outputable body) => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc pprPatBind pat (grhss) = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] -pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body) +pprMatch :: (OutputableBndrId idR, Outputable body) => Match (GhcPass idR) body -> SDoc pprMatch match = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) @@ -1650,7 +1651,7 @@ pprMatch match (pat1:pats1) = m_pats match (pat2:pats2) = pats1 -pprGRHSs :: (OutputableBndrId (GhcPass idR), Outputable body) +pprGRHSs :: (OutputableBndrId idR, Outputable body) => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) @@ -1660,7 +1661,7 @@ pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) (text "where" $$ nest 4 (pprBinds binds)) pprGRHSs _ (XGRHSs x) = ppr x -pprGRHS :: (OutputableBndrId (GhcPass idR), Outputable body) +pprGRHS :: (OutputableBndrId idR, Outputable body) => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc pprGRHS ctxt (GRHS _ [] body) = pp_rhs ctxt body @@ -2104,14 +2105,13 @@ instance (Outputable (StmtLR idL idL (LHsExpr idL)), ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts ppr (XParStmtBlock x) = ppr x -instance (idL ~ GhcPass pl,idR ~ GhcPass pr, - OutputableBndrId idL, OutputableBndrId idR, +instance (OutputableBndrId pl, OutputableBndrId pr, Outputable body) - => Outputable (StmtLR idL idR body) where + => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where ppr stmt = pprStmt stmt -pprStmt :: forall idL idR body . (OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), +pprStmt :: forall idL idR body . (OutputableBndrId idL, + OutputableBndrId idR, Outputable body) => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc pprStmt (LastStmt _ expr ret_stripped _) @@ -2190,7 +2190,7 @@ pprStmt (ApplicativeStmt _ args mb_join) pprStmt (XStmtLR x) = ppr x -pprTransformStmt :: (OutputableBndrId (GhcPass p)) +pprTransformStmt :: (OutputableBndrId p) => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) -> Maybe (LHsExpr (GhcPass p)) -> SDoc pprTransformStmt bndrs using by @@ -2208,7 +2208,7 @@ pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = text "by" <+> ppr e -pprDo :: (OutputableBndrId (GhcPass p), Outputable body) +pprDo :: (OutputableBndrId p, Outputable body) => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts @@ -2218,13 +2218,13 @@ pprDo ListComp stmts = brackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -ppr_do_stmts :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), +ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc -- Print a bunch of do stmts ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) -pprComp :: (OutputableBndrId (GhcPass p), Outputable body) +pprComp :: (OutputableBndrId p, Outputable body) => [LStmt (GhcPass p) body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals @@ -2239,7 +2239,7 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: (OutputableBndrId (GhcPass p), Outputable body) +pprQuals :: (OutputableBndrId p, Outputable body) => [LStmt (GhcPass p) body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals @@ -2429,31 +2429,31 @@ splices. In contrast, when pretty printing the output of the type checker, we sense, although I hate to add another constructor to HsExpr. -} -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsSplicedThing p) where +instance OutputableBndrId p + => Outputable (HsSplicedThing (GhcPass p)) where ppr (HsSplicedExpr e) = ppr_expr e ppr (HsSplicedTy t) = ppr t ppr (HsSplicedPat p) = ppr p -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsSplice p) where +instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where ppr s = pprSplice s -pprPendingSplice :: (OutputableBndrId (GhcPass p)) +pprPendingSplice :: (OutputableBndrId p) => SplicePointName -> LHsExpr (GhcPass p) -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) -pprSpliceDecl :: (OutputableBndrId (GhcPass p)) +pprSpliceDecl :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" pprSpliceDecl e ImplicitSplice = ppr_splice_decl e -ppr_splice_decl :: (OutputableBndrId (GhcPass p)) +ppr_splice_decl :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty ppr_splice_decl e = pprSplice e -pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc +pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc pprSplice (HsTypedSplice _ HasParens n e) = ppr_splice (text "$$(") n e (text ")") pprSplice (HsTypedSplice _ HasDollar n e) @@ -2476,7 +2476,7 @@ ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" -ppr_splice :: (OutputableBndrId (GhcPass p)) +ppr_splice :: (OutputableBndrId p) => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc ppr_splice herald n e trail = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail @@ -2506,12 +2506,12 @@ isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True isTypedBracket _ = False -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsBracket p) where +instance OutputableBndrId p + => Outputable (HsBracket (GhcPass p)) where ppr = pprHsBracket -pprHsBracket :: (OutputableBndrId (GhcPass p)) => HsBracket (GhcPass p) -> SDoc +pprHsBracket :: (OutputableBndrId p) => HsBracket (GhcPass p) -> SDoc pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e) pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p) pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) @@ -2557,8 +2557,8 @@ data ArithSeqInfo id (LHsExpr id) -- AZ: Sould ArithSeqInfo have a TTG extension? -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (ArithSeqInfo p) where +instance OutputableBndrId p + => Outputable (ArithSeqInfo (GhcPass p)) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] @@ -2748,8 +2748,8 @@ pprStmtContext (TransStmtCtxt c) = ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) (pprStmtContext c) -instance (Outputable p, Outputable (NameOrRdrName p)) - => Outputable (HsStmtContext p) where +instance (Outputable (GhcPass p), Outputable (NameOrRdrName (GhcPass p))) + => Outputable (HsStmtContext (GhcPass p)) where ppr = pprStmtContext -- Used to generate the string for a *runtime* error message @@ -2776,7 +2776,7 @@ matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block" matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" -pprMatchInCtxt :: (OutputableBndrId (GhcPass idR), +pprMatchInCtxt :: (OutputableBndrId idR, -- TODO:AZ these constraints do not make sense Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), Outputable body) @@ -2785,8 +2785,8 @@ pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) 4 (pprMatch match) -pprStmtInCtxt :: (OutputableBndrId (GhcPass idL), - OutputableBndrId (GhcPass idR), +pprStmtInCtxt :: (OutputableBndrId idL, + OutputableBndrId idR, Outputable body) => HsStmtContext (IdP (GhcPass idL)) -> StmtLR (GhcPass idL) (GhcPass idR) body diff --git a/compiler/GHC/Hs/Expr.hs-boot b/compiler/GHC/Hs/Expr.hs-boot index 8fd8f3857a..03029d1d05 100644 --- a/compiler/GHC/Hs/Expr.hs-boot +++ b/compiler/GHC/Hs/Expr.hs-boot @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} @@ -28,24 +29,24 @@ data MatchGroup (a :: *) (body :: *) data GRHSs (a :: *) (body :: *) data SyntaxExpr (i :: *) -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) +instance OutputableBndrId p => Outputable (HsExpr (GhcPass p)) +instance OutputableBndrId p => Outputable (HsCmd (GhcPass p)) type LHsExpr a = Located (HsExpr a) -pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc +pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc -pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc +pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc -pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc +pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc -pprSpliceDecl :: (OutputableBndrId (GhcPass p)) +pprSpliceDecl :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc -pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr), - OutputableBndrId (GhcPass p), +pprPatBind :: forall bndr p body. (OutputableBndrId bndr, + OutputableBndrId p, Outputable body) => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc -pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body) +pprFunBind :: (OutputableBndrId idR, Outputable body) => MatchGroup (GhcPass idR) body -> SDoc diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index 35afc5f8d3..b73855eb7a 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -1162,13 +1162,13 @@ type OutputableX p = -- See Note [OutputableX] -- ---------------------------------------------------------------------- -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both --- the @id@ and the 'NameOrRdrName' type for it -type OutputableBndrId id = - ( OutputableBndr (NameOrRdrName (IdP id)) - , OutputableBndr (IdP id) - , OutputableBndr (NameOrRdrName (IdP (NoGhcTc id))) - , OutputableBndr (IdP (NoGhcTc id)) - , NoGhcTc id ~ NoGhcTc (NoGhcTc id) - , OutputableX id - , OutputableX (NoGhcTc id) +-- the @p@ and the 'NameOrRdrName' type for it +type OutputableBndrId pass = + ( OutputableBndr (NameOrRdrName (IdP (GhcPass pass))) + , OutputableBndr (IdP (GhcPass pass)) + , OutputableBndr (NameOrRdrName (IdP (NoGhcTc (GhcPass pass)))) + , OutputableBndr (IdP (NoGhcTc (GhcPass pass))) + , NoGhcTc (GhcPass pass) ~ NoGhcTc (NoGhcTc (GhcPass pass)) + , OutputableX (GhcPass pass) + , OutputableX (NoGhcTc (GhcPass pass)) ) diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 56d1691ac4..32cc3b21a9 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -8,6 +8,7 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] @@ -125,8 +126,8 @@ simpleImportDecl mn = ImportDecl { ideclHiding = Nothing } -instance (p ~ GhcPass pass,OutputableBndrId p) - => Outputable (ImportDecl p) where +instance OutputableBndrId p + => Outputable (ImportDecl (GhcPass p)) where ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe @@ -322,7 +323,7 @@ replaceWrappedName (IEType (L l _)) n = IEType (L l n) replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') -instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where +instance OutputableBndrId p => Outputable (IE (GhcPass p)) where ppr (IEVar _ var) = ppr (unLoc var) ppr (IEThingAbs _ thing) = ppr (unLoc thing) ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"] diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index ab30de87ac..963bf0e2c0 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} @@ -227,7 +228,7 @@ instance Ord OverLitVal where compare (HsIsString _ _) (HsFractional _) = GT -- Instance specific to GhcPs, need the SourceText -instance p ~ GhcPass pass => Outputable (HsLit p) where +instance Outputable (HsLit (GhcPass p)) where ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) ppr (HsString st s) = pprWithSourceText st (pprHsString s) @@ -249,8 +250,8 @@ pp_st_suffix NoSourceText _ doc = doc pp_st_suffix (SourceText st) suffix _ = text st <> suffix -- in debug mode, print the expression that it's resolved to, too -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsOverLit p) where +instance OutputableBndrId p + => Outputable (HsOverLit (GhcPass p)) where ppr (OverLit {ol_val=val, ol_witness=witness}) = ppr val <+> (whenPprDebug (parens (pprExpr witness))) ppr (XOverLit x) = ppr x diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index fe8a4e88d5..25b0a1e184 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -504,7 +504,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl ************************************************************************ -} -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where +instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where ppr = pprPat pprPatBndr :: OutputableBndr name => name -> SDoc @@ -516,11 +516,11 @@ pprPatBndr var -- Print with type info if -dppr-debug is on else pprPrefixOcc var -pprParendLPat :: (OutputableBndrId (GhcPass p)) +pprParendLPat :: (OutputableBndrId p) => PprPrec -> LPat (GhcPass p) -> SDoc pprParendLPat p = pprParendPat p . unLoc -pprParendPat :: (OutputableBndrId (GhcPass p)) +pprParendPat :: (OutputableBndrId p) => PprPrec -> Pat (GhcPass p) -> SDoc pprParendPat p pat = sdocWithDynFlags $ \ dflags -> if need_parens dflags pat @@ -535,7 +535,7 @@ pprParendPat p pat = sdocWithDynFlags $ \ dflags -> -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc +pprPat :: (OutputableBndrId p) => Pat (GhcPass p) -> SDoc pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) pprPat (WildPat _) = char '_' pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat @@ -577,12 +577,12 @@ pprPat (ConPatOut { pat_con = con pprPat (XPat x) = ppr x -pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p)) +pprUserCon :: (OutputableBndr con, OutputableBndrId p) => con -> HsConPatDetails (GhcPass p) -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details -pprConArgs :: (OutputableBndrId (GhcPass p)) +pprConArgs :: (OutputableBndrId p) => HsConPatDetails (GhcPass p) -> SDoc pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats) pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 @@ -696,7 +696,7 @@ looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False looksLazyPat _ = True -isIrrefutableHsPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> Bool +isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass p) -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, -- in the sense of falling through to the next pattern. -- (NB: this is not quite the same as the (silly) defn diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot index 801f481879..fc5671c27a 100644 --- a/compiler/GHC/Hs/Pat.hs-boot +++ b/compiler/GHC/Hs/Pat.hs-boot @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder {-# LANGUAGE ConstraintKinds #-} @@ -15,4 +16,4 @@ type role Pat nominal data Pat (i :: *) type LPat i = Pat i -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) +instance (OutputableBndrId p) => Outputable (Pat (GhcPass p)) diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index 04fd1ee8e6..cd5e59745b 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -901,8 +901,8 @@ data ConDeclField pass -- Record fields have Haddoc docs on them type instance XConDeclField (GhcPass _) = NoExtField type instance XXConDeclField (GhcPass _) = NoExtCon -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (ConDeclField p) where +instance OutputableBndrId p + => Outputable (ConDeclField (GhcPass p)) where ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty ppr (XConDeclField x) = ppr x @@ -1377,8 +1377,8 @@ data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass | XFieldOcc (XXFieldOcc pass) -deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p) -deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p) +deriving instance Eq (XCFieldOcc (GhcPass p)) => Eq (FieldOcc (GhcPass p)) +deriving instance Ord (XCFieldOcc (GhcPass p)) => Ord (FieldOcc (GhcPass p)) type instance XCFieldOcc GhcPs = NoExtField type instance XCFieldOcc GhcRn = Name @@ -1420,10 +1420,10 @@ type instance XAmbiguous GhcTc = Id type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon -instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where +instance Outputable (AmbiguousFieldOcc (GhcPass p)) where ppr = ppr . rdrNameAmbiguousFieldOcc -instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where +instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc @@ -1459,30 +1459,30 @@ ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec ************************************************************************ -} -instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where +instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where ppr ty = pprHsType ty instance Outputable HsTyLit where ppr = ppr_tylit -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (LHsQTyVars p) where +instance OutputableBndrId p + => Outputable (LHsQTyVars (GhcPass p)) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs ppr (XLHsQTyVars x) = ppr x -instance (p ~ GhcPass pass, OutputableBndrId p) - => Outputable (HsTyVarBndr p) where +instance OutputableBndrId p + => Outputable (HsTyVarBndr (GhcPass p)) where ppr (UserTyVar _ n) = ppr n ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] ppr (XTyVarBndr nec) = noExtCon nec -instance (p ~ GhcPass pass,Outputable thing) - => Outputable (HsImplicitBndrs p thing) where +instance Outputable thing + => Outputable (HsImplicitBndrs (GhcPass p) thing) where ppr (HsIB { hsib_body = ty }) = ppr ty ppr (XHsImplicitBndrs x) = ppr x -instance (p ~ GhcPass pass,Outputable thing) - => Outputable (HsWildCardBndrs p thing) where +instance Outputable thing + => Outputable (HsWildCardBndrs (GhcPass p) thing) where ppr (HsWC { hswc_body = ty }) = ppr ty ppr (XHsWildCardBndrs x) = ppr x @@ -1491,7 +1491,7 @@ pprAnonWildCard = char '_' -- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ -- only when @-dppr-debug@ is enabled. -pprHsForAll :: (OutputableBndrId (GhcPass p)) +pprHsForAll :: (OutputableBndrId p) => ForallVisFlag -> [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc pprHsForAll = pprHsForAllExtra Nothing @@ -1503,7 +1503,7 @@ pprHsForAll = pprHsForAllExtra Nothing -- function for this is needed, as the extra-constraints wildcard is removed -- from the actual context and type, and stored in a separate field, thus just -- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: (OutputableBndrId (GhcPass p)) +pprHsForAllExtra :: (OutputableBndrId p) => Maybe SrcSpan -> ForallVisFlag -> [LHsTyVarBndr (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc @@ -1517,7 +1517,7 @@ pprHsForAllExtra extra fvf qtvs cxt -- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print -- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing' -pprHsExplicitForAll :: (OutputableBndrId (GhcPass p)) +pprHsExplicitForAll :: (OutputableBndrId p) => ForallVisFlag -> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs @@ -1530,14 +1530,14 @@ ppr_forall_separator :: ForallVisFlag -> SDoc ppr_forall_separator ForallVis = space <> arrow ppr_forall_separator ForallInvis = dot -pprLHsContext :: (OutputableBndrId (GhcPass p)) +pprLHsContext :: (OutputableBndrId p) => LHsContext (GhcPass p) -> SDoc pprLHsContext lctxt | null (unLoc lctxt) = empty | otherwise = pprLHsContextAlways lctxt -- For use in a HsQualTy, which always gets printed if it exists. -pprLHsContextAlways :: (OutputableBndrId (GhcPass p)) +pprLHsContextAlways :: (OutputableBndrId p) => LHsContext (GhcPass p) -> SDoc pprLHsContextAlways (L _ ctxt) = case ctxt of @@ -1546,7 +1546,7 @@ pprLHsContextAlways (L _ ctxt) _ -> parens (interpp'SP ctxt) <+> darrow -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprLHsContextExtra :: (OutputableBndrId (GhcPass p)) +pprLHsContextExtra :: (OutputableBndrId p) => Bool -> LHsContext (GhcPass p) -> SDoc pprLHsContextExtra show_extra lctxt@(L _ ctxt) | not show_extra = pprLHsContext lctxt @@ -1555,7 +1555,7 @@ pprLHsContextExtra show_extra lctxt@(L _ ctxt) where ctxt' = map ppr ctxt ++ [char '_'] -pprConDeclFields :: (OutputableBndrId (GhcPass p)) +pprConDeclFields :: (OutputableBndrId p) => [LConDeclField (GhcPass p)] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where @@ -1581,13 +1581,13 @@ seems like the Right Thing anyway.) -- Printing works more-or-less as for Types -pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc +pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc pprHsType ty = ppr_mono_ty ty -ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc +ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc +ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc ppr_mono_ty (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }) = sep [pprHsForAll fvf tvs noLHsContext, ppr_mono_lty ty] @@ -1644,7 +1644,7 @@ ppr_mono_ty (HsDocTy _ ty doc) ppr_mono_ty (XHsType t) = ppr t -------------------------- -ppr_fun_ty :: (OutputableBndrId (GhcPass p)) +ppr_fun_ty :: (OutputableBndrId p) => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc ppr_fun_ty ty1 ty2 = let p1 = ppr_mono_lty ty1 |