X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsDecls.lhs;h=d4f6628b68d6d4da66e077cab06036d240df8dcd;hp=9f9073560e22796080aacaa73997a62404b38b1e;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hpb=fa6fb09e2e4e6918eebc79ed187f32c88817c9db

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 9f90735..d4f6628 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -31,7 +31,7 @@ import Outputable	( interppSP, interpp'SP,
 			)
 import Pretty
 import SrcLoc		( SrcLoc )
-import PprStyle		( PprStyle(..) )
+import PprStyle		( PprStyle(..), ifaceStyle )
 \end{code}
 
 
@@ -71,6 +71,10 @@ instance (NamedThing name, Outputable name, Outputable pat,
     ppr sty (ValD binds) = ppr sty binds
     ppr sty (DefD def)   = ppr sty def
     ppr sty (InstD inst) = ppr sty inst
+
+-- In interfaces, top-level binders are printed without their "Module." prefix
+ppr_top_binder sty bndr | ifaceStyle sty = ppr sty (getOccName bndr)
+	  	        | otherwise	 = ppr sty bndr
 \end{code}
 
 
@@ -143,12 +147,12 @@ instance (NamedThing name, Outputable name)
 		  derivings
 
 pp_decl_head sty str pp_context tycon tyvars
-  = ppCat [ppPStr str, pp_context, ppr sty (getOccName tycon), 
+  = ppCat [ppPStr str, pp_context, ppr_top_binder sty tycon,
 	   interppSP sty tyvars, ppPStr SLIT("=")]
 
 pp_condecls sty [] = ppNil		-- Curious!
 pp_condecls sty (c:cs)
-  = ppSep (ppr sty c : map (\ c -> ppBeside (ppStr "| ") (ppr sty c)) cs)
+  = ppSep (ppr sty c : map (\ c -> ppBeside (ppPStr SLIT("| ")) (ppr sty c)) cs)
 
 pp_tydecl sty pp_head pp_decl_rhs derivings
   = ppHang pp_head 4 (ppSep [
@@ -215,25 +219,26 @@ data BangType name
 instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
 
     ppr sty (ConDecl con tys _)
-      = ppCat [ppr sty (getOccName con), ppInterleave ppNil (map (ppr_bang sty) tys)]
+      = ppCat [ppr_top_binder sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
 
 	-- We print ConOpDecls in prefix form in interface files
-    ppr PprInterface (ConOpDecl ty1 op ty2 _)
-      = ppCat [ppr PprInterface (getOccName op), ppr_bang PprInterface ty1, ppr_bang PprInterface ty2]
     ppr sty (ConOpDecl ty1 op ty2 _)
-      = ppCat [ppr_bang sty ty1, ppr sty (getOccName op), ppr_bang sty ty2]
+      | ifaceStyle sty
+      = ppCat [ppr_top_binder sty op, ppr_bang sty ty1, ppr_bang sty ty2]
+      | otherwise
+      = ppCat [ppr_bang sty ty1, ppr_top_binder sty op, ppr_bang sty ty2]
 
     ppr sty (NewConDecl con ty _)
-      = ppCat [ppr sty (getOccName con), pprParendHsType sty ty]
+      = ppCat [ppr_top_binder sty con, pprParendHsType sty ty]
     ppr sty (RecConDecl con fields _)
-      = ppCat [ppr sty (getOccName con),
+      = ppCat [ppr_top_binder sty con,
 	       ppCurlies (ppInterleave pp'SP (map pp_field fields))
 	      ]
       where
-	pp_field (ns, ty) = ppCat [ppCat (map (ppr sty . getOccName) ns), 
+	pp_field (ns, ty) = ppCat [ppCat (map (ppr_top_binder sty) ns), 
 				   ppPStr SLIT("::"), ppr_bang sty ty]
 
-ppr_bang sty (Banged   ty) = ppBeside (ppStr "! ") (pprParendHsType sty ty)
+ppr_bang sty (Banged   ty) = ppBeside (ppPStr SLIT("! ")) (pprParendHsType sty ty)
 				-- The extra space helps the lexical analyser that lexes
 				-- interface files; it doesn't make the rigid operator/identifier
 				-- distinction, so "!a" is a valid identifier so far as it is concerned
@@ -267,16 +272,16 @@ instance (NamedThing name, Outputable name, Outputable pat,
       = top_matter
 
       | iface_style	-- All on one line (for now at least)
-      = ppCat [top_matter, ppStr "where", 
+      = ppCat [top_matter, ppPStr SLIT("where"), 
 	       ppCurlies (ppInterleave (ppPStr SLIT("; ")) pp_sigs)]
 
       | otherwise	-- Laid out
-      = ppSep [ppCat [top_matter, ppStr "where {"],
+      = ppSep [ppCat [top_matter, ppPStr SLIT("where {")],
 	       ppNest 4 ((ppIntersperse ppSemi pp_sigs `ppAbove` pp_methods)
-			 `ppBeside` ppStr "}")]
+			 `ppBeside` ppChar '}')]
       where
-        top_matter = ppCat [ppStr "class", pp_context_and_arrow sty context,
-                            ppr sty (getOccName clas), ppr sty tyvar]
+        top_matter = ppCat [ppPStr SLIT("class"), pp_context_and_arrow sty context,
+                            ppr_top_binder sty clas, ppr sty tyvar]
 	pp_sigs     = map (ppr sty) sigs 
 	pp_methods  = ppr sty methods
 	iface_style = case sty of {PprInterface -> True; other -> False}
@@ -311,10 +316,10 @@ instance (NamedThing name, Outputable name, Outputable pat,
     ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc)
       | case sty of { PprInterface -> True; other -> False} ||
 	nullMonoBinds binds && null uprags
-      = ppCat [ppStr "instance", ppr sty inst_ty]
+      = ppCat [ppPStr SLIT("instance"), ppr sty inst_ty]
 
       | otherwise
-      =	ppAboves [ppCat [ppStr "instance", ppr sty inst_ty, ppStr "where"],
+      =	ppAboves [ppCat [ppPStr SLIT("instance"), ppr sty inst_ty, ppPStr SLIT("where")],
 	          ppNest 4 (ppr sty uprags),
 	          ppNest 4 (ppr sty binds) ]
 \end{code}
@@ -372,7 +377,7 @@ data IfaceSig name
 
 instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
     ppr sty (IfaceSig var ty _ _)
-      = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
+      = ppHang (ppCat [ppr_top_binder sty var, ppPStr SLIT("::")])
 	     4 (ppr sty ty)
 
 data HsIdInfo name