From 288b674de9b09e782e7a407d65add2d6ebf1acab Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Wed, 29 Jan 2020 10:15:01 +0000 Subject: Try dropping OutputableBndrId in favor of IsPass --- compiler/GHC/Hs/Extension.hs | 30 ++++++++++++++++++++++++------ compiler/GHC/Hs/ImpExp.hs | 13 +++++++++---- compiler/GHC/Hs/Types.hs | 15 +++++++++------ 3 files changed, 42 insertions(+), 16 deletions(-) diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index ebc5da93fa..cb6b654dee 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -28,10 +28,10 @@ module GHC.Hs.Extension where import GhcPrelude import Data.Data hiding ( Fixity ) -import GHC.Hs.PlaceHolder import Name import RdrName import Var +import PprCore () -- for instance OutputableBndr Var import Outputable import SrcLoc (Located) @@ -222,9 +222,14 @@ pass = ghcPass @(GhcPass p) -- | Maps the "normal" id type for a given pass type family IdP p -type instance IdP GhcPs = RdrName -type instance IdP GhcRn = Name -type instance IdP GhcTc = Id +type instance IdP (GhcPass p) = IdGhcP p + +-- | Maps the "normal" id type for a GhcPass. +type family IdGhcP p = r | r -> p where + -- injective to allow us to write pprIdP + IdGhcP 'Parsed = RdrName + IdGhcP 'Renamed = Name + IdGhcP 'Typechecked = Id type LIdP p = Located (IdP p) @@ -720,11 +725,12 @@ type family XXIE x -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both -- the @id@ and the 'NameOrRdrName' type for it type OutputableBndrId pass = - ( OutputableBndr (NameOrRdrName (IdP (GhcPass pass))) + -- RAE: this change is just to minimise churn while experimenting + ( {- OutputableBndr (NameOrRdrName (IdP (GhcPass pass))) , OutputableBndr (IdP (GhcPass pass)) , OutputableBndr (NameOrRdrName (IdP (NoGhcTc (GhcPass pass)))) , OutputableBndr (IdP (NoGhcTc (GhcPass pass))) - , IsPass pass + , -} IsPass pass ) -- useful helper functions: @@ -739,3 +745,15 @@ pprIfRn pp = case pass @p of GhcRn -> pp pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc pprIfTc pp = case pass @p of GhcTc -> pp _ -> empty + +pprIdP :: forall p. IsPass p => IdGhcP p -> SDoc +pprIdP var = withOutputableBndr @p $ ppr var + +pprLIdP :: forall p. IsPass p => Located (IdGhcP p) -> SDoc +pprLIdP var = withOutputableBndr @p $ ppr var + +withOutputableBndr :: forall pass r. IsPass pass + => (OutputableBndr (IdP (GhcPass pass)) => r) -> r +withOutputableBndr k = case pass @pass of GhcPs -> k + GhcRn -> k + GhcTc -> k diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 32cc3b21a9..87851c89f5 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -13,6 +13,8 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] -- in module GHC.Hs.PlaceHolder +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module GHC.Hs.ImpExp where @@ -324,14 +326,17 @@ replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') 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 "(..)"] + ppr (IEVar _ var) = withOutputableBndr @p $ ppr (unLoc var) + ppr (IEThingAbs _ thing) = withOutputableBndr @p $ ppr (unLoc thing) + ppr (IEThingAll _ thing) = withOutputableBndr @p $ hcat [ppr (unLoc thing), text "(..)"] ppr (IEThingWith _ thing wc withs flds) - = ppr (unLoc thing) <> parens (fsep (punctuate comma + = withOutputableBndr @p $ + ppr (unLoc thing) <> parens (fsep (punctuate comma (ppWiths ++ map (ppr . flLabel . unLoc) flds))) where + ppWiths :: OutputableBndr (IdP (GhcPass p)) => [SDoc] + -- this type signature is necessary because of -XMonoLocalBinds ppWiths = case wc of NoIEWildcard -> diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index bc7ba47434..d97dd108e6 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -16,6 +16,8 @@ GHC.Hs.Types: Abstract syntax: user-defined types {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module GHC.Hs.Types ( HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, @@ -1439,8 +1441,8 @@ instance OutputableBndrId p 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 (UserTyVar _ n) = pprLIdP n + ppr (KindedTyVar _ n k) = parens $ hsep [pprLIdP n, dcolon, ppr k] ppr (XTyVarBndr nec) = noExtCon nec instance Outputable thing @@ -1554,7 +1556,7 @@ pprHsType ty = ppr_mono_ty ty ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc +ppr_mono_ty :: forall p. (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] @@ -1564,8 +1566,8 @@ ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds ppr_mono_ty (HsTyVar _ prom (L _ name)) - | isPromoted prom = quote (pprPrefixOcc name) - | otherwise = pprPrefixOcc name + | isPromoted prom = withOutputableBndr @p $ quote (pprPrefixOcc name) + | otherwise = withOutputableBndr @p $ pprPrefixOcc name ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2 ppr_mono_ty (HsTupleTy _ con tys) -- Special-case unary boxed tuples so that they are pretty-printed as @@ -1605,7 +1607,8 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) ppr_mono_ty (HsAppKindTy _ ty k) = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2) - = sep [ ppr_mono_lty ty1 + = withOutputableBndr @p $ + sep [ ppr_mono_lty ty1 , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ] ppr_mono_ty (HsParTy _ ty) -- cgit v1.2.1