[project @ 1996-04-21 13:39:09 by partain]

[ghc-hetmet.git] / ghc / compiler / types / PprType.lhs

diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index be52e99..fa790ac 100644 (file)
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -23,7 +23,6 @@ module PprType(
 import Ubiq
 import IdLoop  -- for paranoia checking
 import TyLoop  -- for paranoia checking
-import NameLoop        -- for paranoia checking
 
 -- friends:
 -- (PprType can see all the representations it's trying to print)
@@ -39,8 +38,10 @@ import Kind          ( Kind(..) )
 import CStrings                ( identToC )
 import CmdLineOpts     ( opt_OmitInterfacePragmas )
 import Maybes          ( maybeToBool )
-import NameTypes       ( ShortName, FullName )
-import Outputable      ( ifPprShowAll, isAvarop, interpp'SP )
+import Name            ( isLexVarSym, isPreludeDefined, origName, moduleOf,
+                         Name{-instance Outputable-}
+                       )
+import Outputable      ( ifPprShowAll, interpp'SP )
 import PprStyle                ( PprStyle(..), codeStyle, showUserishTypes )
 import Pretty
 import TysWiredIn      ( listTyCon )
@@ -172,13 +173,16 @@ ppr_ty sty env ctxt_prec (DictTy clas ty usage)
 
 -- Some help functions
 ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys
-  = ASSERT(length arg_tys == 2)
+  | length arg_tys == 2
+  = (if length arg_tys /= 2 then pprTrace "ppr_corner:" (ppCat (map (ppr_ty sty env ctxt_prec) arg_tys)) else id) $
+    ASSERT(length arg_tys == 2)
     ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
   where
     (ty1:ty2:_) = arg_tys
 
-ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon a) usage) arg_tys
-  = ASSERT(length arg_tys == a)
+ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
+  = --ASSERT(length arg_tys == a)
+    (if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $
     ppBesides [ppLparen, arg_tys_w_commas, ppRparen]
   where
     arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
@@ -302,7 +306,7 @@ pprGenTyVar sty (TyVar uniq kind name usage)
 %*                                                                     *
 %************************************************************************
 
-ToDo; all this is suspiciously like getOccurrenceName!
+ToDo; all this is suspiciously like getOccName!
 
 \begin{code}
 showTyCon :: PprStyle -> TyCon -> String
@@ -311,17 +315,11 @@ showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon)
 pprTyCon :: PprStyle -> TyCon -> Pretty
 
 pprTyCon sty FunTyCon                  = ppStr "(->)"
-pprTyCon sty (TupleTyCon arity)                = ppBeside (ppPStr SLIT("Tuple")) (ppInt arity)
+pprTyCon sty (TupleTyCon _ name _)      = ppr sty name
 pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name
 
-pprTyCon sty tycon@(DataTyCon uniq kind name tyvars ctxt cons derivings nd)
-  = case sty of
-      PprDebug   -> pp_tycon_and_uniq
-      PprShowAll -> pp_tycon_and_uniq
-      _                 -> pp_tycon
-  where
-    pp_tycon_and_uniq = ppBesides [pp_tycon, ppChar '.', pprUnique uniq]
-    pp_tycon         = ppr sty name
+pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
+  = ppr sty name
 
 pprTyCon sty (SpecTyCon tc ty_maybes)
   = ppBeside (pprTyCon sty tc)
@@ -362,7 +360,7 @@ ppr_class_op sty tyvars (ClassOp op_name i ty)
       _                    -> pp_user
   where
     pp_C    = ppPStr op_name
-    pp_user = if isAvarop op_name
+    pp_user = if isLexVarSym op_name
              then ppBesides [ppLparen, pp_C, ppRparen]
              else pp_C
 \end{code}
@@ -391,9 +389,9 @@ getTypeString ty
       = case (maybeAppTyCon ty) of
          Nothing -> true_bottom
          Just (tycon,_) ->
-           if fromPreludeCore tycon
+           if isPreludeDefined tycon
            then true_bottom
-           else (False, fst (getOrigName tycon))
+           else (False, moduleOf (origName tycon))
 
     true_bottom = (True, panic "getTypeString")
 
@@ -442,7 +440,7 @@ pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs
     ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
           ppEquals, ppr_ty sty lookup_fn tOP_PREC exp]
 
-pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings data_or_new) specs
+pprTyCon sty@PprInterface this_tycon@(DataTyCon u n k vs ctxt cons derivings data_or_new) specs
   = ppHang (ppCat [pp_data_or_new,
                   pprContext sty ctxt,
                   ppr sty n,
@@ -505,7 +503,7 @@ pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings dat
          = let
                (_, _, con_arg_tys, _) = dataConSig con
            in
-           ppCat [pprNonOp PprForUser con, -- the data con's name...
+           ppCat [pprNonSym PprForUser con, -- the data con's name...
                   ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
 
        ppr_next_con con = ppCat [ppChar '|', ppr_con con]
@@ -523,9 +521,9 @@ pprTyCon sty@PprInterface this_tycon@(DataTyCon k n a vs ctxt cons derivings dat
 
     pp_NONE = ppPStr SLIT("_N_")
 
-pprTyCon PprInterface (TupleTyCon a) specs
+pprTyCon PprInterface (TupleTyCon _ name _) specs
   = ASSERT (null specs)
-    ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ]
+    ppCat [ ppStr "{- ", ppr PprForUser name, ppStr "-}" ]
 
 pprTyCon PprInterface (PrimTyCon k n a kind_fn) specs
   = ASSERT (null specs)