Better pretty-printing for HsType, fixes Trac #7645
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 14 Feb 2013 14:37:43 +0000 (14:37 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 14 Feb 2013 14:37:43 +0000 (14:37 +0000)
compiler/basicTypes/Name.lhs
compiler/basicTypes/RdrName.lhs
compiler/hsSyn/HsTypes.lhs
compiler/prelude/PrelNames.lhs-boot

index 281ae93..e112625 100644 (file)
@@ -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.
+
index 3ff3bbb..ff98923 100644 (file)
@@ -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
index 74aa477..d0d9e1a 100644 (file)
@@ -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
index c14695b..7b5365e 100644 (file)
@@ -1,9 +1,10 @@
-
 \begin{code}
 module PrelNames where
 
 import Module
+import Unique
 
 mAIN :: Module
+liftedTypeKindTyConKey :: Unique
 \end{code}