[commit: ghc] master: Better pretty-printing for HsType, fixes Trac #7645 (599aaf4)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/599aaf4e4dbb94a484eed5f624404194c6ca1fb9

>---------------------------------------------------------------

commit 599aaf4e4dbb94a484eed5f624404194c6ca1fb9
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Feb 14 14:37:43 2013 +0000

    Better pretty-printing for HsType, fixes Trac #7645

>---------------------------------------------------------------

 compiler/basicTypes/Name.lhs        |   24 ++++++++++++++++++++++--
 compiler/basicTypes/RdrName.lhs     |    6 +++++-
 compiler/hsSyn/HsTypes.lhs          |    2 +-
 compiler/prelude/PrelNames.lhs-boot |    3 ++-
 4 files changed, 30 insertions(+), 5 deletions(-)

diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index 281ae93..e112625 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -73,6 +73,7 @@ module Name (
 #include "Typeable.h"
 
 import {-# SOURCE #-} TypeRep( TyThing )
+import {-# SOURCE #-} PrelNames( liftedTypeKindTyConKey )
 
 import OccName
 import Module
@@ -566,7 +567,26 @@ getOccString        = occNameString        . getOccName
 pprInfixName, pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc
 -- See Outputable.pprPrefixVar, pprInfixVar;
 -- add parens or back-quotes as appropriate
-pprInfixName  n = pprInfixVar  (isSymOcc (getOccName n)) (ppr n)
-pprPrefixName n = pprPrefixVar (isSymOcc (getOccName n)) (ppr n)
+pprInfixName  n = pprInfixVar (isSymOcc (getOccName n)) (ppr n)
+
+pprPrefixName thing 
+ |  name `hasKey` liftedTypeKindTyConKey 
+ = ppr name   -- See Note [Special treatment for kind *]
+ | otherwise
+ = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name)
+ where
+   name = getName thing
 \end{code}
 
+Note [Special treatment for kind *]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do not put parens around the kind '*'.  Even though it looks like
+an operator, it is really a special case.
+
+This pprPrefixName stuff is really only used when printing HsSyn,
+which has to be polymorphic in the name type, and hence has to go via
+the overloaded function pprPrefixOcc.  It's easier where we know the
+type being pretty printed; eg the pretty-printing code in TypeRep.
+
+See Trac #7645, which led to this.
+
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index 3ff3bbb..ff98923 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -277,7 +277,11 @@ instance OutputableBndr RdrName where
 	| otherwise		 = ppr n
 
     pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
-    pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
+    pprPrefixOcc rdr 
+      | Just name <- isExact_maybe rdr = pprPrefixName name
+             -- pprPrefixName has some special cases, so
+             -- we delegate to them rather than reproduce them
+      | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
 
 instance Eq RdrName where
     (Exact n1) 	  == (Exact n2)    = n1==n2
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 74aa477..d0d9e1a 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -614,7 +614,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
 ppr_mono_ty _    (HsBangTy b ty)     = ppr b <> ppr_mono_lty pREC_CON ty
 ppr_mono_ty _    (HsQuasiQuoteTy qq) = ppr qq
 ppr_mono_ty _    (HsRecTy flds)      = pprConDeclFields flds
-ppr_mono_ty _    (HsTyVar name)      = ppr name
+ppr_mono_ty _    (HsTyVar name)      = pprPrefixOcc name
 ppr_mono_ty prec (HsFunTy ty1 ty2)   = ppr_fun_ty prec ty1 ty2
 ppr_mono_ty _    (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
   where std_con = case con of
diff --git a/compiler/prelude/PrelNames.lhs-boot b/compiler/prelude/PrelNames.lhs-boot
index c14695b..7b5365e 100644
--- a/compiler/prelude/PrelNames.lhs-boot
+++ b/compiler/prelude/PrelNames.lhs-boot
@@ -1,9 +1,10 @@
-
 \begin{code}
 module PrelNames where
 
 import Module
+import Unique
 
 mAIN :: Module
+liftedTypeKindTyConKey :: Unique
 \end{code}