[commit: ghc] type-nats: Fix pretty-printing of type operators in imports/exports. (0044864)

[Iavor Diatchki]

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

On branch  : type-nats

http://hackage.haskell.org/trac/ghc/changeset/00448643b9ac5ae0be89a31fa48d41ff66181d7d

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

commit 00448643b9ac5ae0be89a31fa48d41ff66181d7d
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date:   Sat Mar 24 13:27:43 2012 -0700

    Fix pretty-printing of type operators in imports/exports.
    
    When we see a type operator in an import or an export, we tag it
    with the keyword 'type' so that it is not confused with value level
    operators with the same name.

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

 compiler/basicTypes/Name.lhs    |    3 +++
 compiler/basicTypes/OccName.lhs |    6 ++++++
 compiler/basicTypes/RdrName.lhs |    4 ++++
 compiler/hsSyn/HsImpExp.lhs     |   19 ++++++++++++++-----
 compiler/hsSyn/HsSyn.lhs        |    3 ++-
 compiler/rename/RnNames.lhs     |    2 +-
 6 files changed, 30 insertions(+), 7 deletions(-)

diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index e4a9c7d..a26729f 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -168,6 +168,9 @@ Wired-in thing  => The thing (Id, TyCon) is fully known to the compiler,
 All built-in syntax is for wired-in things.
 
 \begin{code}
+instance HasOccName Name where
+  occName = nameOccName
+
 nameUnique		:: Name -> Unique
 nameOccName		:: Name -> OccName 
 nameModule		:: Name -> Module
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index e160d4e..27e995a 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -54,6 +54,7 @@ module OccName (
 	mkTupleOcc, 
 	setOccNameSpace,
         demoteOccName,
+        HasOccName(..),
 
 	-- ** Derived 'OccName's
         isDerivedOccName,
@@ -334,6 +335,11 @@ demoteOccName :: OccName -> Maybe OccName
 demoteOccName (OccName space name) = do
   space' <- demoteNameSpace space
   return $ OccName space' name
+
+{- | Other names in the compiler add aditional information to an OccName.
+This class provides a consistent way to access the underlying OccName. -}
+class HasOccName name where
+  occName :: name -> OccName
 \end{code}
 
 
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index de0ff56..22bd41f 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -130,6 +130,10 @@ data RdrName
 %************************************************************************
 
 \begin{code}
+
+instance HasOccName RdrName where
+  occName = rdrNameOcc
+
 rdrNameOcc :: RdrName -> OccName
 rdrNameOcc (Qual _ occ) = occ
 rdrNameOcc (Unqual occ) = occ
diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs
index ee75414..7163cbf 100644
--- a/compiler/hsSyn/HsImpExp.lhs
+++ b/compiler/hsSyn/HsImpExp.lhs
@@ -12,6 +12,7 @@ module HsImpExp where
 
 import Module           ( ModuleName )
 import HsDoc            ( HsDocString )
+import OccName          ( HasOccName(..), isTcOcc, isSymOcc )
 
 import Outputable
 import FastString
@@ -57,7 +58,7 @@ simpleImportDecl mn = ImportDecl {
 \end{code}
 
 \begin{code}
-instance (OutputableBndr name) => Outputable (ImportDecl name) where
+instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) where
     ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg
                     , ideclSource = from, ideclSafe = safe
                     , ideclQualified = qual, ideclImplicit = implicit
@@ -134,12 +135,20 @@ ieNames (IEDocNamed       _   ) = []
 \end{code}
 
 \begin{code}
-instance (OutputableBndr name, Outputable name) => Outputable (IE name) where
+
+pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc
+pprImpExp name = type_pref <+> pprPrefixOcc name
+    where
+    occ = occName name
+    type_pref | isTcOcc occ && isSymOcc occ = ptext (sLit "type")
+              | otherwise                   = empty
+
+instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where
     ppr (IEVar          var)    = pprPrefixOcc var
-    ppr (IEThingAbs     thing)  = ppr thing
-    ppr (IEThingAll     thing)  = hcat [ppr thing, text "(..)"]
+    ppr (IEThingAbs     thing)  = pprImpExp thing
+    ppr (IEThingAll     thing)  = hcat [pprImpExp thing, text "(..)"]
     ppr (IEThingWith thing withs)
-        = pprPrefixOcc thing <> parens (fsep (punctuate comma (map pprPrefixOcc withs)))
+        = pprImpExp thing <> parens (fsep (punctuate comma (map pprImpExp withs)))
     ppr (IEModuleContents mod')
         = ptext (sLit "module") <+> ppr mod'
     ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")
diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs
index a8ae81e..ba1794d 100644
--- a/compiler/hsSyn/HsSyn.lhs
+++ b/compiler/hsSyn/HsSyn.lhs
@@ -46,6 +46,7 @@ import HsUtils
 import HsDoc
 
 -- others:
+import OccName          ( HasOccName )
 import IfaceSyn		( IfaceBinding )
 import Outputable
 import SrcLoc
@@ -97,7 +98,7 @@ data HsExtCore name	-- Read from Foo.hcr
 instance Outputable Char where
   ppr c = text [c]
 
-instance (OutputableBndr name)
+instance (OutputableBndr name, HasOccName name)
 	=> Outputable (HsModule name) where
 
     ppr (HsModule Nothing _ imports decls _ mbDoc)
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 553c3ef..0ecefbc 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -1612,7 +1612,7 @@ dodgyImportWarn item = dodgyMsg (ptext (sLit "import")) item
 dodgyExportWarn :: Name -> SDoc
 dodgyExportWarn item = dodgyMsg (ptext (sLit "export")) item
 
-dodgyMsg :: OutputableBndr n => SDoc -> n -> SDoc
+dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc
 dodgyMsg kind tc
   = sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item") <+> quotes (ppr (IEThingAll tc))
                 <+> ptext (sLit "suggests that"),