X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=b83f4b8fcd4e2fe5bd090f0c5ed961299aab7aba;hb=9c26739695219d8343505a88457cb55c76b65449;hp=195809dc3427c93826d646e92d417de2960a401a;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 195809d..b83f4b8 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -23,11 +23,11 @@ module HsTypes (
 
 IMP_Ubiq()
 
-import Outputable	( interppSP, ifnotPprForUser )
+import CmdLineOpts      ( opt_PprUserLength )
+import Outputable	( Outputable(..), PprStyle(..), pprQuote, interppSP )
 import Kind		( Kind {- instance Outputable -} )
 import Name		( nameOccName )
 import Pretty
-import PprStyle		( PprStyle(..) )
 import Util		( thenCmp, cmpList, isIn, panic# )
 \end{code}
 
@@ -100,34 +100,27 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
 \begin{code}
 
 instance (Outputable name) => Outputable (HsType name) where
-    ppr = pprHsType
+    ppr sty ty = pprQuote sty $ \ sty -> pprHsType sty ty
 
 instance (Outputable name) => Outputable (HsTyVar name) where
-    ppr sty (UserTyVar name) = ppr_hs_tyname sty name
-    ppr sty (IfaceTyVar name kind) = ppCat [ppr_hs_tyname sty name, ppPStr SLIT("::"), ppr sty kind]
-
-
--- Here comes a rather gross hack.  
--- We want to print data and class decls in interface files, from the original source
--- When we do, we want the type variables to come out with their original names, not
--- some new unique (or else interfaces wobble too much).  So when we come to one of
--- these type variables we sneakily change the style to PprForUser!
-ppr_hs_tyname PprInterface tv_name = ppr PprForUser tv_name
-ppr_hs_tyname other_sty    tv_name = ppr other_sty tv_name
+    ppr sty (UserTyVar name)       = ppr sty name
+    ppr sty (IfaceTyVar name kind) = pprQuote sty $ \ sty ->
+				     hsep [ppr sty name, ptext SLIT("::"), ppr sty kind]
 
 ppr_forall sty ctxt_prec [] [] ty
    = ppr_mono_ty sty ctxt_prec ty
 ppr_forall sty ctxt_prec tvs ctxt ty
-   = ppSep [ppPStr SLIT("_forall_"), ppBracket (interppSP sty tvs),
-	    pprContext sty ctxt,  ppPStr SLIT("=>"),
+   = maybeParen (ctxt_prec >= pREC_FUN) $
+     sep [ptext SLIT("_forall_"), brackets (interppSP sty tvs),
+	    pprContext sty ctxt,  ptext SLIT("=>"),
 	    pprHsType sty ty]
 
-pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
-pprContext sty []	        = ppNil
+pprContext :: (Outputable name) => PprStyle -> (Context name) -> Doc
+pprContext sty []	        = empty
 pprContext sty context
-  = ppCat [ppCurlies (ppIntersperse pp'SP (map ppr_assert context))]
+  = hsep [braces (hsep (punctuate comma (map ppr_assert context)))]
   where
-    ppr_assert (clas, ty) = ppCat [ppr sty clas, ppr sty ty]
+    ppr_assert (clas, ty) = hsep [ppr sty clas, ppr sty ty]
 \end{code}
 
 \begin{code}
@@ -135,13 +128,13 @@ pREC_TOP = (0 :: Int)
 pREC_FUN = (1 :: Int)
 pREC_CON = (2 :: Int)
 
-maybeParen :: Bool -> Pretty -> Pretty
-maybeParen True  p = ppParens p
+maybeParen :: Bool -> Doc -> Doc
+maybeParen True  p = parens p
 maybeParen False p = p
 	
 -- printing works more-or-less as for Types
 
-pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Pretty
+pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Doc
 
 pprHsType sty ty       = ppr_mono_ty sty pREC_TOP ty
 pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty
@@ -149,28 +142,27 @@ pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty
 ppr_mono_ty sty ctxt_prec (HsPreForAllTy ctxt ty)     = ppr_forall sty ctxt_prec [] ctxt ty
 ppr_mono_ty sty ctxt_prec (HsForAllTy tvs ctxt ty)    = ppr_forall sty ctxt_prec tvs ctxt ty
 
-ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr_hs_tyname sty name
+ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
 
 ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2)
   = let p1 = ppr_mono_ty sty pREC_FUN ty1
 	p2 = ppr_mono_ty sty pREC_TOP ty2
     in
     maybeParen (ctxt_prec >= pREC_FUN)
-	       (ppSep [p1, ppBeside (ppPStr SLIT("-> ")) p2])
+	       (sep [p1, (<>) (ptext SLIT("-> ")) p2])
 
 ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys)
- = ppParens (ppInterleave ppComma (map (ppr sty) tys))
+ = parens (sep (punctuate comma (map (ppr sty) tys)))
 
 ppr_mono_ty sty ctxt_prec (MonoListTy _ ty)
- = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack]
+ = brackets (ppr_mono_ty sty pREC_TOP ty)
 
 ppr_mono_ty sty ctxt_prec (MonoTyApp fun_ty arg_ty)
   = maybeParen (ctxt_prec >= pREC_CON)
-	       (ppCat [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty])
+	       (hsep [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty])
 
 ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
-  = ppCurlies (ppCat [ppr sty clas, ppr_mono_ty sty pREC_CON ty])
-	-- Curlies are temporary
+  = hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty]
 \end{code}
 
 
@@ -186,8 +178,8 @@ wrong}, so be careful!
 
 \begin{code}
 cmpHsTyVar :: (a -> a -> TAG_) -> HsTyVar a -> HsTyVar a -> TAG_
-cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_
-cmpContext  :: (a -> a -> TAG_) -> Context  a -> Context  a -> TAG_
+--cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_
+--cmpContext  :: (a -> a -> TAG_) -> Context  a -> Context  a -> TAG_
 
 cmpHsTyVar cmp (UserTyVar v1)    (UserTyVar v2)    = v1 `cmp` v2
 cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2