X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FPprType.lhs;h=4a04bffb5528f5923dabfa47ed0fc0edf17d7071;hb=8655d6ca41df4aa77a559d4067ad3815797b9803;hp=a4c6d2cf195d26b5b97c45fd64e5c2fecc36d2e8;hpb=ae45ff0e9831a0dc862a5d68d03e355d7e323c62;p=ghc-hetmet.git diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index a4c6d2c..4a04bff 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -1,361 +1,235 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % -\section[PprType]{Printing Types, TyVars, Classes, ClassOps, TyCons} +\section[PprType]{Printing Types, TyVars, Classes, TyCons} \begin{code} -#include "HsVersions.h" - module PprType( - GenTyVar, pprGenTyVar, - TyCon, pprTyCon, showTyCon, - GenType, - pprGenType, pprParendGenType, + pprKind, pprParendKind, pprType, pprParendType, - pprMaybeTy, - getTypeString, - typeMaybeString, - specMaybeTysSuffix, - GenClass, - GenClassOp, pprGenClassOp, - - addTyVar{-ToDo:don't export-}, nmbrTyVar, - addUVar, nmbrUsage, - nmbrType, nmbrTyCon, nmbrClass + pprSourceType, pprPred, pprTheta, pprClassPred, + pprTyVarBndr, pprTyVarBndrs, + + -- Junk + getTyDescription, showTypeCategory ) where -IMP_Ubiq() -IMPORT_DELOOPER(IdLoop) -- for paranoia checking -IMPORT_DELOOPER(TyLoop) -- for paranoia checking +#include "HsVersions.h" -- friends: -- (PprType can see all the representations it's trying to print) -import Type ( GenType(..), maybeAppTyCon, - splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy ) -import TyVar ( GenTyVar(..) ) -import TyCon ( TyCon(..), NewOrData ) -import Class ( Class(..), GenClass(..), - ClassOp(..), GenClassOp(..) ) -import Kind ( Kind(..) ) -import Usage ( GenUsage(..) ) +import TypeRep ( Type(..), TyNote(..), Kind ) -- friend +import Type ( SourceType(..) ) +import TcType ( ThetaType, PredType, TyThing(..), + tcSplitSigmaTy, isPredTy, isDictTy, + tcSplitTyConApp_maybe, tcSplitFunTy_maybe + ) +import Var ( TyVar, tyVarKind ) +import Class ( Class ) +import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, tupleTyConBoxity, + maybeTyConSingleCon, isEnumerationTyCon, tyConArity + ) -- others: -import CStrings ( identToC ) -import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( maybeToBool ) -import Name ( isLexVarSym, isLexSpecialSym, origName, moduleOf, - getLocalName, Name{-instance Outputable-} - ) -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 Unique ( pprUnique10, pprUnique, incrUnique, listTyConKey ) -import Usage ( UVar(..), pprUVar ) -import Util -\end{code} - -\begin{code} -instance (Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where - ppr sty ty = pprGenType sty ty - -instance Outputable TyCon where - ppr sty tycon = pprTyCon sty tycon - -instance Outputable (GenClass tyvar uvar) where - -- we use pprIfaceClass for printing in interfaces - ppr sty (Class u n _ _ _ _ _ _ _ _) = ppr sty n - -instance Outputable ty => Outputable (GenClassOp ty) where - ppr sty clsop = pprGenClassOp sty clsop - -instance Outputable (GenTyVar flexi) where - ppr sty tv = pprGenTyVar sty tv - --- and two SPECIALIZEd ones: -instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where - ppr sty ty = pprGenType sty ty - -instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where - ppr sty ty = pprGenTyVar sty ty +import Name ( getOccString, getOccName ) +import OccName ( occNameUserString ) +import Outputable +import Unique ( Uniquable(..) ) +import Util ( lengthIs ) +import BasicTypes ( IPName(..), tupleParens, ipNameName ) +import PrelNames -- quite a few *Keys \end{code} %************************************************************************ %* * -\subsection[Type]{@Type@} +\subsection{The external interface} %* * %************************************************************************ -@pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is -defined to use this. @pprParendGenType@ is the same, except it puts -parens around the type, except for the atomic cases. @pprParendGenType@ +@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is +defined to use this. @pprParendType@ is the same, except it puts +parens around the type, except for the atomic cases. @pprParendType@ works just by setting the initial context precedence very high. \begin{code} -pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> GenType tyvar uvar -> Pretty - -pprGenType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC ty -pprParendGenType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC ty - -pprType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC (ty :: Type) -pprParendType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC (ty :: Type) - -pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Maybe (GenType tyvar uvar) -> Pretty -pprMaybeTy sty Nothing = ppChar '*' -pprMaybeTy sty (Just ty) = pprParendGenType sty ty -\end{code} - -\begin{code} -ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> PprEnv tyvar uvar bndr occ -> Int - -> GenType tyvar uvar - -> Pretty - -ppr_ty sty env ctxt_prec (TyVarTy tyvar) - = ppr_tyvar env tyvar +pprType, pprParendType :: Type -> SDoc +pprType ty = ppr_ty tOP_PREC ty +pprParendType ty = ppr_ty tYCON_PREC ty -ppr_ty sty env ctxt_prec (TyConTy tycon usage) - = ppr sty tycon +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType -ppr_ty sty env ctxt_prec ty@(ForAllTy _ _) - | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty +pprPred :: PredType -> SDoc +pprPred = pprSourceType - | otherwise = ppSep [ ppPStr SLIT("_forall_"), - ppIntersperse pp'SP pp_tyvars, - ppPStr SLIT("=>"), - ppr_ty sty env' ctxt_prec body_ty - ] - where - (tyvars, body_ty) = splitForAllTy ty - env' = foldl add_tyvar env tyvars - pp_tyvars = map (ppr_tyvar env') tyvars - -ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty) - = panic "ppr_ty:ForAllUsageTy" - -ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _) - | showUserishTypes sty - -- Print a nice looking context (Eq a, Text b) => ... - = ppSep [ppBeside (ppr_theta theta) (ppPStr SLIT(" =>")), - ppr_ty sty env ctxt_prec body_ty - ] - where - (theta, body_ty) = splitRhoTy ty - - ppr_theta = case sty of { PprInterface -> ppr_theta_2 ; _ -> ppr_theta_1 } - - ppr_theta_1 [ct] = ppr_dict sty env tOP_PREC ct - ppr_theta_1 cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts)) - - ppr_theta_2 cts = ppBesides [ppStr "{{", ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts), ppStr "}}"] - -ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) - -- We fiddle the precedences passed to left/right branches, - -- so that right associativity comes out nicely... - = maybeParen ctxt_prec fUN_PREC - (ppCat [ppr_ty sty env fUN_PREC ty1, - ppPStr SLIT("->"), - ppr_ty sty env tOP_PREC ty2]) - -ppr_ty sty env ctxt_prec ty@(AppTy _ _) - = ppr_corner sty env ctxt_prec fun_ty arg_tys - where - (fun_ty, arg_tys) = splitAppTy ty - -{- OLD: -ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion) - -- always expand types in an interface - = ppr_ty PprInterface env ctxt_prec expansion --} - -ppr_ty sty env ctxt_prec (SynTy tycon tys expansion) - = ppBeside - (ppr_app sty env ctxt_prec (ppr sty tycon) tys) - (ifPprShowAll sty (ppCat [ppStr " {- expansion:", - ppr_ty sty env tOP_PREC expansion, - ppStr "-}"])) +pprSourceType :: SourceType -> SDoc +pprSourceType (ClassP clas tys) = pprClassPred clas tys +pprSourceType (IParam n ty) = hsep [ppr n, dcolon, ppr ty] +pprSourceType (NType tc tys) = ppr tc <+> sep (map pprParendType tys) -ppr_ty sty env ctxt_prec (DictTy clas ty usage) - = ppr_dict sty env ctxt_prec (clas, ty) +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys) +pprTheta :: ThetaType -> SDoc +pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) --- Some help functions -ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys - | length arg_tys == 2 - = ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) - where - (ty1:ty2:_) = arg_tys +instance Outputable Type where + ppr ty = pprType ty -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) +instance Outputable SourceType where + ppr = pprPred -ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys - | tycon == listTyCon - = ASSERT(length arg_tys == 1) - ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack] - where - (ty1:_) = arg_tys - -ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys - = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys - -ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys - = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys - - -ppr_app sty env ctxt_prec pp_fun [] - = pp_fun -ppr_app sty env ctxt_prec pp_fun arg_tys - = maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces]) - where - arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys) +instance Outputable name => Outputable (IPName name) where + ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters + ppr (Linear n) = char '%' <> ppr n -- Splittable implicit parameters +instance Outputable name => OutputableBndr (IPName name) where + pprBndr _ n = ppr n -- Simple for now -ppr_dict sty env ctxt_prec (clas, ty) - = maybeParen ctxt_prec tYCON_PREC - (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty]) +instance Outputable TyThing where + ppr (AnId id) = ptext SLIT("AnId") <+> ppr id + ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc + ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl + ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr dc \end{code} -This stuff is effectively stubbed out for the time being -(WDP 960425): -\begin{code} -init_ppr_env sty - = initPprEnv sty b b b b b b b b b b b - where - b = panic "PprType:init_ppr_env" -ppr_tyvar env tyvar = ppr (pStyle env) tyvar -ppr_uvar env uvar = ppr (pStyle env) uvar - -add_tyvar env tyvar = env -add_uvar env uvar = env -\end{code} +%************************************************************************ +%* * +\subsection{Pretty printing} +%* * +%************************************************************************ +Precedence +~~~~~~~~~~ @ppr_ty@ takes an @Int@ that is the precedence of the context. The precedence levels are: \begin{description} -\item[0:] What we start with. -\item[1:] Function application (@FunTys@). -\item[2:] Type constructors. +\item[tOP_PREC] No parens required. +\item[fUN_PREC] Left hand argument of a function arrow. +\item[tYCON_PREC] Argument of a type constructor. \end{description} \begin{code} -tOP_PREC = (0 :: Int) -fUN_PREC = (1 :: Int) -tYCON_PREC = (2 :: Int) +tOP_PREC = (0 :: Int) -- type in ParseIface.y +fUN_PREC = (1 :: Int) -- btype in ParseIface.y +tYCON_PREC = (2 :: Int) -- atype in ParseIface.y maybeParen ctxt_prec inner_prec pretty | ctxt_prec < inner_prec = pretty - | otherwise = ppParens pretty -\end{code} - -%************************************************************************ -%* * -\subsection[TyVar]{@TyVar@} -%* * -%************************************************************************ - -\begin{code} -pprGenTyVar sty (TyVar uniq kind name usage) - = case sty of - PprInterface -> pp_u - _ -> ppBesides [pp_name, ppStr "{-", pp_u, ppStr "-}"] - where - pp_u = pprUnique uniq - pp_name = case name of - Just n -> ppPStr (getLocalName n) - Nothing -> case kind of - TypeKind -> ppChar 'o' - BoxedTypeKind -> ppChar 't' - UnboxedTypeKind -> ppChar 'u' - ArrowKind _ _ -> ppChar 'a' + | otherwise = parens pretty \end{code} -%************************************************************************ -%* * -\subsection[TyCon]{@TyCon@} -%* * -%************************************************************************ - -ToDo; all this is suspiciously like getOccName! - \begin{code} -showTyCon :: PprStyle -> TyCon -> String -showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon) - -maybe_code sty = if codeStyle sty then identToC else ppPStr - -pprTyCon :: PprStyle -> TyCon -> Pretty - -pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name - -pprTyCon sty FunTyCon = maybe_code sty SLIT("(->)") -pprTyCon sty (TupleTyCon _ _ arity) = case arity of - 0 -> maybe_code sty SLIT("()") - 2 -> maybe_code sty SLIT("(,)") - 3 -> maybe_code sty SLIT("(,,)") - 4 -> maybe_code sty SLIT("(,,,)") - 5 -> maybe_code sty SLIT("(,,,,)") - n -> maybe_code sty (_PK_ ( "(" ++ nOfThem (n-1) ',' ++ ")")) - -pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd) - | uniq == listTyConKey - = maybe_code sty SLIT("[]") +ppr_ty :: Int -> Type -> SDoc +ppr_ty ctxt_prec (TyVarTy tyvar) + = ppr tyvar + +ppr_ty ctxt_prec ty@(TyConApp tycon tys) + -- KIND CASE; it's of the form (Type x) + | tycon `hasKey` typeConKey, + [ty] <- tys + = -- For kinds, print (Type x) as just x if x is a + -- type constructor (must be Boxed, Unboxed, AnyBox) + -- Otherwise print as (Type x) + case ty of + TyConApp bx [] -> ppr (getOccName bx) -- Always unqualified + other -> maybeParen ctxt_prec tYCON_PREC + (ppr tycon <+> ppr_ty tYCON_PREC ty) + + -- TUPLE CASE (boxed and unboxed) + | isTupleTyCon tycon, + tys `lengthIs` tyConArity tycon -- No magic if partially applied + = tupleParens (tupleTyConBoxity tycon) + (sep (punctuate comma (map (ppr_ty tOP_PREC) tys))) + + -- LIST CASE + | tycon `hasKey` listTyConKey, + [ty] <- tys + = brackets (ppr_ty tOP_PREC ty) + + -- PARALLEL ARRAY CASE + | tycon `hasKey` parrTyConKey, + [ty] <- tys + = pabrackets (ppr_ty tOP_PREC ty) + + -- GENERAL CASE | otherwise - = ppr sty name + = ppr_tc_app ctxt_prec tycon tys -pprTyCon sty (SpecTyCon tc ty_maybes) - = ppBeside (pprTyCon sty tc) - (if (codeStyle sty) - then identToC tys_stuff - else ppPStr tys_stuff) where - tys_stuff = specMaybeTysSuffix ty_maybes - -pprTyCon sty (SynTyCon uniq name kind arity tyvars expansion) - = ppBeside (ppr sty name) - (ifPprShowAll sty - (ppCat [ ppStr " {-", - ppInt arity, - interpp'SP sty tyvars, - pprParendGenType sty expansion, - ppStr "-}"])) + pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") + + +ppr_ty ctxt_prec ty@(ForAllTy _ _) + = getPprStyle $ \ sty -> + maybeParen ctxt_prec fUN_PREC $ + sep [ ptext SLIT("forall") <+> pp_tyvars sty <> ptext SLIT("."), + ppr_theta theta, + ppr_ty tOP_PREC tau + ] + where + (tyvars, theta, tau) = tcSplitSigmaTy ty + pp_tyvars sty = sep (map pprTyVarBndr tyvars) + + ppr_theta [] = empty + ppr_theta theta = pprTheta theta <+> ptext SLIT("=>") + + +ppr_ty ctxt_prec (FunTy ty1 ty2) + -- we don't want to lose usage annotations or synonyms, + -- so we mustn't use splitFunTys here. + = maybeParen ctxt_prec fUN_PREC $ + sep [ ppr_ty fUN_PREC ty1 + , ptext arrow <+> ppr_ty tOP_PREC ty2 + ] + where arrow | isPredTy ty1 = SLIT("=>") + | otherwise = SLIT("->") + +ppr_ty ctxt_prec (AppTy ty1 ty2) + = maybeParen ctxt_prec tYCON_PREC $ + ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2 + +ppr_ty ctxt_prec (NoteTy (SynNote ty) expansion) + = ppr_ty ctxt_prec ty +-- = ppr_ty ctxt_prec expansion -- if we don't want to see syntys + +ppr_ty ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty ctxt_prec ty + +ppr_ty ctxt_prec (SourceTy (NType tc tys)) = ppr_tc_app ctxt_prec tc tys +ppr_ty ctxt_prec (SourceTy pred) = braces (pprPred pred) + +ppr_tc_app ctxt_prec tc [] = ppr tc +ppr_tc_app ctxt_prec tc tys = maybeParen ctxt_prec tYCON_PREC + (sep [ppr tc, nest 4 (sep (map (ppr_ty tYCON_PREC) tys))]) \end{code} %************************************************************************ %* * -\subsection[Class]{@Class@} +\subsection[TyVar]{@TyVar@} %* * %************************************************************************ -\begin{code} -pprGenClassOp :: Outputable ty => PprStyle -> GenClassOp ty -> Pretty - -pprGenClassOp sty op = ppr_class_op sty [] op +We print type-variable binders with their kinds in interface files, +and when in debug mode. -ppr_class_op sty tyvars (ClassOp op_name i ty) - = case sty of - PprForC -> pp_C - PprForAsm _ _ -> pp_C - PprInterface -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty] - PprShowAll -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty] - _ -> pp_user +\begin{code} +pprTyVarBndr :: TyVar -> SDoc +pprTyVarBndr tyvar + = getPprStyle $ \ sty -> + if debugStyle sty then + hsep [ppr tyvar, dcolon, pprParendKind kind] + -- See comments with ppDcolon in PprCore.lhs + else + ppr tyvar where - pp_C = ppPStr op_name - pp_user = if isLexVarSym op_name && not (isLexSpecialSym op_name) - then ppParens pp_C - else pp_C + kind = tyVarKind tyvar + +pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars) \end{code} @@ -365,214 +239,81 @@ ppr_class_op sty tyvars (ClassOp op_name i ty) %* * %************************************************************************ -\begin{code} - -- Shallowly magical; converts a type into something - -- vaguely close to what can be used in C identifier. - -- Don't forget to include the module name!!! -getTypeString :: Type -> [FAST_STRING] -getTypeString ty = [mod, string] - where - string = _PK_ (tidy (ppShow 1000 ppr_t)) - ppr_t = pprGenType PprForC ty - -- PprForC expands type synonyms as it goes - - mod - = case (maybeAppTyCon ty) of - Nothing -> panic "getTypeString" - Just (tycon,_) -> moduleOf (origName "getTypeString" tycon) - - -------------------------------------------------- - -- tidy: very ad-hoc - tidy [] = [] -- done - - tidy (' ' : more) - = case more of - ' ' : _ -> tidy more - '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs) - other -> ' ' : tidy more - - tidy (',' : more) = ',' : tidy (no_leading_sps more) - - tidy (x : xs) = x : tidy xs -- catch all - - no_leading_sps [] = [] - no_leading_sps (' ':xs) = no_leading_sps xs - no_leading_sps other = other - -typeMaybeString :: Maybe Type -> [FAST_STRING] -typeMaybeString Nothing = [SLIT("!")] -typeMaybeString (Just t) = getTypeString t - -specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING -specMaybeTysSuffix ty_maybes - = let - ty_strs = concat (map typeMaybeString ty_maybes) - dotted_tys = [ _CONS_ '.' str | str <- ty_strs ] - in - _CONCAT_ dotted_tys -\end{code} - -ToDo: possibly move: -\begin{code} -nmbrType :: Type -> NmbrM Type - -nmbrType (TyVarTy tv) - = nmbrTyVar tv `thenNmbr` \ new_tv -> - returnNmbr (TyVarTy new_tv) - -nmbrType (AppTy t1 t2) - = nmbrType t1 `thenNmbr` \ new_t1 -> - nmbrType t2 `thenNmbr` \ new_t2 -> - returnNmbr (AppTy new_t1 new_t2) - -nmbrType (TyConTy tc use) - = --nmbrTyCon tc `thenNmbr` \ new_tc -> - nmbrUsage use `thenNmbr` \ new_use -> - returnNmbr (TyConTy tc new_use) - -nmbrType (SynTy tc args expand) - = --nmbrTyCon tc `thenNmbr` \ new_tc -> - mapNmbr nmbrType args `thenNmbr` \ new_args -> - nmbrType expand `thenNmbr` \ new_expand -> - returnNmbr (SynTy tc new_args new_expand) - -nmbrType (ForAllTy tv ty) - = addTyVar tv `thenNmbr` \ new_tv -> - nmbrType ty `thenNmbr` \ new_ty -> - returnNmbr (ForAllTy new_tv new_ty) - -nmbrType (ForAllUsageTy u us ty) - = addUVar u `thenNmbr` \ new_u -> - mapNmbr nmbrUVar us `thenNmbr` \ new_us -> - nmbrType ty `thenNmbr` \ new_ty -> - returnNmbr (ForAllUsageTy new_u new_us new_ty) - -nmbrType (FunTy t1 t2 use) - = nmbrType t1 `thenNmbr` \ new_t1 -> - nmbrType t2 `thenNmbr` \ new_t2 -> - nmbrUsage use `thenNmbr` \ new_use -> - returnNmbr (FunTy new_t1 new_t2 new_use) - -nmbrType (DictTy c ty use) - = --nmbrClass c `thenNmbr` \ new_c -> - nmbrType ty `thenNmbr` \ new_ty -> - nmbrUsage use `thenNmbr` \ new_use -> - returnNmbr (DictTy c new_ty new_use) -\end{code} - -\begin{code} -addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar - -addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) - = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $ - case (lookupUFM_Directly tvenv u) of - Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $ - -- (It gets triggered when we do a datatype: first we - -- "addTyVar" the tyvars for the datatype as a whole; - -- we will subsequently "addId" the data cons, including - -- the type for each of them -- each of which includes - -- _forall_ ...tvs..., which we will addTyVar. - -- Harmless, if that's all that happens.... - (nenv, xx) - Nothing -> - let - nenv_plus_tv = NmbrEnv ui (incrUnique ut) uu - idenv - (addToUFM_Directly tvenv u new_tv) - uvenv - - (nenv2, new_use) = nmbrUsage use nenv_plus_tv - - new_tv = TyVar ut k maybe_name new_use - in - (nenv2, new_tv) - -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])) $ - (nenv, tv) -\end{code} +Grab a name for the type. This is used to determine the type +description for profiling. -nmbrTyCon : only called from ``top-level'', if you know what I mean. \begin{code} -nmbrTyCon tc@FunTyCon = returnNmbr tc -nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc -nmbrTyCon tc@(PrimTyCon _ _ _ _) = returnNmbr tc - -nmbrTyCon (DataTyCon u n k tvs theta cons clss nod) - = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $ - mapNmbr addTyVar tvs `thenNmbr` \ new_tvs -> - mapNmbr nmbr_theta theta `thenNmbr` \ new_theta -> - mapNmbr nmbrId cons `thenNmbr` \ new_cons -> - returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod) +getTyDescription :: Type -> String + +getTyDescription ty + = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> + case tau_ty of + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + FunTy _ res -> '-' : '>' : fun_result res + TyConApp tycon _ -> occNameUserString (getOccName tycon) + NoteTy (FTVNote _) ty -> getTyDescription ty + NoteTy (SynNote ty1) _ -> getTyDescription ty1 + SourceTy sty -> getSourceTyDescription sty + ForAllTy _ ty -> getTyDescription ty + } where - nmbr_theta (c,t) - = --nmbrClass c `thenNmbr` \ new_c -> - nmbrType t `thenNmbr` \ new_t -> - returnNmbr (c, new_t) - -nmbrTyCon (SynTyCon u n k a tvs expand) - = mapNmbr addTyVar tvs `thenNmbr` \ new_tvs -> - nmbrType expand `thenNmbr` \ new_expand -> - returnNmbr (SynTyCon u n k a new_tvs new_expand) - -nmbrTyCon (SpecTyCon tc specs) - = mapNmbr nmbrMaybeTy specs `thenNmbr` \ new_specs -> - returnNmbr (SpecTyCon tc new_specs) - ------------ -nmbrMaybeTy Nothing = returnNmbr Nothing -nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t -> - returnNmbr (Just new_t) -\end{code} + fun_result (FunTy _ res) = '>' : fun_result res + fun_result other = getTyDescription other -\begin{code} -nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers) - = addTyVar tv `thenNmbr` \ new_tv -> - mapNmbr nmbr_op ops `thenNmbr` \ new_ops -> - returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers) - where - nmbr_op (ClassOp n tag ty) - = nmbrType ty `thenNmbr` \ new_ty -> - returnNmbr (ClassOp n tag new_ty) +getSourceTyDescription (ClassP cl tys) = getOccString cl +getSourceTyDescription (NType tc tys) = getOccString tc +getSourceTyDescription (IParam ip ty) = getOccString (ipNameName ip) \end{code} -\begin{code} -nmbrUsage :: Usage -> NmbrM Usage - -nmbrUsage u = returnNmbr u -{- LATER: -nmbrUsage u@UsageOne = returnNmbr u -nmbrUsage u@UsageOmega = returnNmbr u -nmbrUsage (UsageVar u) - = nmbrUVar u `thenNmbr` \ new_u -> - returnNmbr (UsageVar new_u) --} -\end{code} \begin{code} -addUVar, nmbrUVar :: UVar -> NmbrM UVar - -addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) - = case (lookupUFM_Directly uvenv u) of - Just xx -> _trace "addUVar: already in map!" $ - (nenv, xx) - Nothing -> - let - nenv_plus_uv = NmbrEnv ui ut (incrUnique uu) - idenv - tvenv - (addToUFM_Directly uvenv u new_uv) - new_uv = uu - in - (nenv_plus_uv, new_uv) - -nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) - = case (lookupUFM_Directly uvenv u) of - Just xx -> (nenv, xx) - Nothing -> - _trace "nmbrUVar: lookup failed" $ - (nenv, u) +showTypeCategory :: Type -> Char + {- + {C,I,F,D} char, int, float, double + T tuple + S other single-constructor type + {c,i,f,d} unboxed ditto + t *unpacked* tuple + s *unpacked" single-cons... + + v void# + a primitive array + + E enumeration type + + dictionary, unless it's a ... + L List + > function + M other (multi-constructor) data-con type + . other type + - reserved for others to mark as "uninteresting" + -} +showTypeCategory ty + = if isDictTy ty + then '+' + else + case tcSplitTyConApp_maybe ty of + Nothing -> if maybeToBool (tcSplitFunTy_maybe ty) + then '>' + else '.' + + Just (tycon, _) -> + let utc = getUnique tycon in + if utc == charDataConKey then 'C' + else if utc == intDataConKey then 'I' + else if utc == floatDataConKey then 'F' + else if utc == doubleDataConKey then 'D' + else if utc == smallIntegerDataConKey || + utc == largeIntegerDataConKey then 'J' + else if utc == charPrimTyConKey then 'c' + else if (utc == intPrimTyConKey || utc == wordPrimTyConKey + || utc == addrPrimTyConKey) then 'i' + else if utc == floatPrimTyConKey then 'f' + else if utc == doublePrimTyConKey then 'd' + else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus + else if isEnumerationTyCon tycon then 'E' + else if isTupleTyCon tycon then 'T' + else if maybeToBool (maybeTyConSingleCon tycon) then 'S' + else if utc == listTyConKey then 'L' + else 'M' -- oh, well... \end{code}