[project @ 1996-07-25 20:43:49 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 5c34749..3001600 100644 (file)
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -16,6 +16,7 @@ module PprType(
        getTypeString,
        typeMaybeString,
        specMaybeTysSuffix,
+       getTyDescription,
        GenClass, 
        GenClassOp, pprGenClassOp,
        
@@ -25,8 +26,8 @@ module PprType(
  ) where
 
 IMP_Ubiq()
-IMPORT_DELOOPER(IdLoop)        -- for paranoia checking
-IMPORT_DELOOPER(TyLoop)        -- for paranoia checking
+IMPORT_DELOOPER(IdLoop)
+--IMPORT_DELOOPER(TyLoop)      -- for paranoia checking
 
 -- friends:
 -- (PprType can see all the representations it's trying to print)
@@ -50,8 +51,7 @@ import Outputable     ( ifPprShowAll, interpp'SP )
 import PprEnv
 import PprStyle                ( PprStyle(..), codeStyle, showUserishTypes )
 import Pretty
-import TysWiredIn      ( listTyCon )
-import UniqFM          ( addToUFM_Directly, lookupUFM_Directly, ufmToList{-ToDo:rm-} )
+import UniqFM          ( addToUFM_Directly, lookupUFM_Directly{-, ufmToList ToDo:rm-} )
 import Unique          ( pprUnique10, pprUnique, incrUnique, listTyConKey )
 import Util
 \end{code}
@@ -197,7 +197,7 @@ ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
     arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
 
 ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
-  | not (codeStyle sty) && tycon == listTyCon
+  | not (codeStyle sty) && uniqueOf tycon == listTyConKey
   = ASSERT(length arg_tys == 1)
     ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]                    
   where
@@ -391,13 +391,13 @@ getTypeString ty
   where
     do_tc (TyConTy tc _) = Left (origName "do_tc" tc)
     do_tc (SynTy _ _ ty) = do_tc ty
-    do_tc other = pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
+    do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $
                  Right (_PK_ (ppShow 1000 (pprType PprForC other)))
 
     do_arg_ty (TyConTy tc _) = Left (origName "do_arg_ty" tc)
     do_arg_ty (TyVarTy tv)   = Right (_PK_ (ppShow 80 (ppr PprForC tv)))
     do_arg_ty (SynTy _ _ ty) = do_arg_ty ty
-    do_arg_ty other         = pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
+    do_arg_ty other         = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $
                               Right (_PK_ (ppShow 1000 (pprType PprForC other)))
 
        -- PprForC expands type synonyms as it goes;
@@ -439,6 +439,28 @@ specMaybeTysSuffix ty_maybes
 -}
 \end{code}
 
+Grab a name for the type. This is used to determine the type
+description for profiling.
+\begin{code}
+getTyDescription :: Type -> String
+
+getTyDescription ty
+  = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
+    case tau_ty of
+      TyVarTy _              -> "*"
+      AppTy fun _     -> getTyDescription fun
+      FunTy _ res _   -> '-' : '>' : fun_result res
+      TyConTy tycon _ -> _UNPK_ (getLocalName tycon)
+      SynTy tycon _ _ -> _UNPK_ (getLocalName tycon)
+      DictTy _ _ _    -> "dict"
+      ForAllTy _ ty   -> getTyDescription ty
+      _                      -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
+    }
+  where
+    fun_result (FunTy _ res _) = '>' : fun_result res
+    fun_result other          = getTyDescription other
+\end{code}
+
 ToDo: possibly move:
 \begin{code}
 nmbrType :: Type -> NmbrM Type
@@ -518,7 +540,7 @@ nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
   = case (lookupUFM_Directly tvenv u) of
       Just xx -> (nenv, xx)
       Nothing ->
-       pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
+       --pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
        (nenv, tv)
 \end{code}