Try dropping OutputableBndrId in favor of IsPasswip/smaller-constraints

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)