getTypeString,
typeMaybeString,
specMaybeTysSuffix,
+ getTyDescription,
GenClass,
GenClassOp, pprGenClassOp,
) 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)
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}
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
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;
-}
\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"
+ _ -> 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
= 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}