X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FPprType.lhs;h=8d0d6755695eeba3a4c98f328cee51aa2802d583;hb=bb91427f27c940e4dd0fc6c7360e7ef61264b240;hp=051ad922cb90786b21c287c74988ca64b3022d57;hpb=e72062f5239a13f243d6e98b5124e2fdbab1c940;p=ghc-hetmet.git diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 051ad92..8d0d675 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -1,93 +1,90 @@ % -% (c) The AQUA Project, Glasgow University, 1996 +% (c) The AQUA Project, Glasgow University, 1996-1998 % \section[PprType]{Printing Types, TyVars, Classes, TyCons} \begin{code} -#include "HsVersions.h" - module PprType( - GenTyVar, pprGenTyVar, pprTyVarBndr, - TyCon, pprTyCon, showTyCon, - GenType, - pprGenType, pprParendGenType, + pprKind, pprParendKind, pprType, pprParendType, - pprMaybeTy, - getTypeString, - specMaybeTysSuffix, - getTyDescription, - GenClass, + pprConstraint, pprPred, pprTheta, + pprTyVarBndr, pprTyVarBndrs, - nmbrType, nmbrGlobalType + -- Junk + getTyDescription, showTypeCategory ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(IdLoop) -#else -import {-# SOURCE #-} Id -#endif - +#include "HsVersions.h" -- friends: -- (PprType can see all the representations it's trying to print) -import Type ( GenType(..), maybeAppTyCon, Type(..), splitFunTy, - splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTys ) -import TyVar ( GenTyVar(..), TyVar(..), cloneTyVar ) -import TyCon ( TyCon, NewOrData, isFunTyCon, isTupleTyCon, tyConArity ) -import Class ( SYN_IE(Class), GenClass(..) ) -import Kind ( Kind(..), isBoxedTypeKind, pprParendKind ) -import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar), cloneUVar ) +import TypeRep ( Type(..), TyNote(..), Kind, UsageAnn(..), + boxedTypeKind, + ) -- friend +import Type ( PredType(..), ThetaType, + splitPredTy_maybe, + splitForAllTys, splitSigmaTy, splitRhoTy, + isDictTy, splitTyConApp_maybe, splitFunTy_maybe, + splitUsForAllTys + ) +import Var ( TyVar, tyVarKind, + tyVarName, setTyVarName + ) +import VarEnv +import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, + maybeTyConSingleCon, isEnumerationTyCon, + tyConArity, tyConUnique + ) +import Class ( Class, className ) -- others: -import CStrings ( identToC ) -import CmdLineOpts ( opt_OmitInterfacePragmas, opt_PprUserLength ) import Maybes ( maybeToBool ) -import Name ( nameString, Name{-instance Outputable-}, - OccName, pprOccName, getOccString, NamedThing(..) - ) -import Outputable ( PprStyle(..), codeStyle, userStyle, ifaceStyle, - ifPprShowAll, interpp'SP, Outputable(..) - ) +import Name ( getOccString, NamedThing(..) ) +import Outputable import PprEnv -import Pretty -import UniqFM ( UniqFM, addToUFM, emptyUFM, lookupUFM ) -import Unique ( Unique, Uniquable(..), pprUnique10, pprUnique, - incrUnique, listTyConKey, initTyVarUnique - ) +import Unique ( Uniquable(..) ) +import Unique -- quite a few *Keys import Util \end{code} +%************************************************************************ +%* * +\subsection{The external interface} +%* * +%************************************************************************ + +@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} -instance (Eq tyvar, Outputable tyvar, - Eq uvar, Outputable uvar ) => Outputable (GenType tyvar uvar) where - ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty) - 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 (GenTyVar flexi) where - ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty) - ppr sty tv = pprGenTyVar sty tv - --- and two SPECIALIZEd ones: -instance Outputable {-Type, i.e.:-}(GenType TyVar UVar) where - ppr PprQuote ty = quotes (pprGenType (PprForUser opt_PprUserLength) ty) - ppr other_sty ty = pprGenType other_sty ty - -instance Outputable {-TyVar, i.e.:-}(GenTyVar Usage) where - ppr PprQuote ty = quotes (pprGenTyVar (PprForUser opt_PprUserLength) ty) - ppr other_sty ty = pprGenTyVar other_sty ty +pprType, pprParendType :: Type -> SDoc +pprType ty = ppr_ty pprTyEnv tOP_PREC ty +pprParendType ty = ppr_ty pprTyEnv tYCON_PREC ty + +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType + +pprPred :: PredType -> SDoc +pprPred (Class clas tys) = pprConstraint clas tys +pprPred (IParam n ty) = hsep [ppr n, ptext SLIT("::"), ppr ty] + +pprConstraint :: Class -> [Type] -> SDoc +pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys) + +pprTheta :: ThetaType -> SDoc +pprTheta theta = parens (hsep (punctuate comma (map pprPred theta))) + +instance Outputable Type where + ppr ty = pprType ty \end{code} + %************************************************************************ %* * -\subsection[Type]{@Type@} +\subsection{Pretty printing} %* * %************************************************************************ @@ -112,416 +109,253 @@ maybeParen ctxt_prec inner_prec pretty | otherwise = parens pretty \end{code} -@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@ -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 -> Doc - -pprGenType sty ty = ppr_ty (init_ppr_env sty) tOP_PREC ty -pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty - -pprType, pprParendType :: PprStyle -> Type -> Doc -pprType sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC ty -pprParendType sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty - -pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) - => PprStyle -> Maybe (GenType tyvar uvar) -> Doc -pprMaybeTy sty Nothing = char '*' -pprMaybeTy sty (Just ty) = pprParendGenType sty ty -\end{code} - \begin{code} -ppr_ty :: PprEnv tyvar uvar bndr occ -> Int - -> GenType tyvar uvar - -> Doc - +ppr_ty :: PprEnv TyVar -> Int -> Type -> SDoc ppr_ty env ctxt_prec (TyVarTy tyvar) = pTyVarO env tyvar -ppr_ty env ctxt_prec (TyConTy tycon usage) - = ppr_tycon env tycon - -ppr_ty env ctxt_prec ty@(ForAllTy _ _) - | show_forall = maybeParen ctxt_prec fUN_PREC $ - sep [ ptext SLIT("_forall_"), pp_tyvars, - ppr_theta env theta, ptext SLIT("=>"), pp_body - ] - | null theta = ppr_ty env ctxt_prec body_ty - | otherwise = maybeParen ctxt_prec fUN_PREC $ - sep [ppr_theta env theta, ptext SLIT("=>"), pp_body] - where - (tyvars, rho_ty) = splitForAllTy ty - (theta, body_ty) | show_context = splitRhoTy rho_ty - | otherwise = ([], rho_ty) - - pp_tyvars = brackets (hsep (map (pTyVarB env) tyvars)) - pp_body = ppr_ty env tOP_PREC body_ty +ppr_ty env ctxt_prec ty@(TyConApp tycon tys) + -- KIND CASE; it's of the form (Type x) + | tycon_uniq == typeConKey && n_tys == 1 + = -- 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 ty1 of + TyConApp bx [] -> ppr bx + other -> maybeParen ctxt_prec tYCON_PREC + (sep [ppr tycon, nest 4 tys_w_spaces]) + + + -- TUPLE CASE (boxed and unboxed) + | isTupleTyCon tycon + && length tys == tyConArity tycon -- no magic if partially applied + = parens tys_w_commas - sty = pStyle env - show_forall = not (userStyle sty) - show_context = ifaceStyle sty || userStyle sty + | isUnboxedTupleTyCon tycon + && length tys == tyConArity tycon -- no magic if partially applied + = parens (char '#' <+> tys_w_commas <+> char '#') -ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty) - = panic "ppr_ty:ForAllUsageTy" + -- LIST CASE + | tycon_uniq == listTyConKey && n_tys == 1 + = brackets (ppr_ty env tOP_PREC ty1) -ppr_ty 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 (sep (ppr_ty env fUN_PREC ty1 : pp_rest)) - where - (arg_tys, result_ty) = splitFunTy ty2 - pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ] + -- DICTIONARY CASE, prints {C a} + -- This means that instance decls come out looking right in interfaces + -- and that in turn means they get "gated" correctly when being slurped in + | maybeToBool maybe_pred + = braces (ppr_pred env pred) -ppr_ty env ctxt_prec ty@(AppTy _ _) - = ppr_corner env ctxt_prec fun_ty arg_tys - where - (fun_ty, arg_tys) = splitAppTys ty - -ppr_ty env ctxt_prec (SynTy tycon tys expansion) - | codeStyle (pStyle env) - -- always expand types that squeak into C-variable names - = ppr_ty env ctxt_prec expansion + -- NO-ARGUMENT CASE (=> no parens) + | null tys + = ppr tycon + -- GENERAL CASE | otherwise - = (<>) - (ppr_app env ctxt_prec (ppr_tycon env tycon) tys) - (ifPprShowAll (pStyle env) (hsep [text " {- expansion:", - ppr_ty env tOP_PREC expansion, - text "-}"])) + = maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces]) -ppr_ty env ctxt_prec (DictTy clas ty usage) - = braces (ppr_dict env tOP_PREC (clas, ty)) - -- Curlies are temporary + where + tycon_uniq = tyConUnique tycon + n_tys = length tys + (ty1:_) = tys + Just pred = maybe_pred + maybe_pred = splitPredTy_maybe ty -- Checks class and arity + tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys)) + tys_w_spaces = sep (map (ppr_ty env tYCON_PREC) tys) + --- Some help functions -ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys - | isFunTyCon tycon && length arg_tys == 2 - = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage) +ppr_ty env ctxt_prec ty@(ForAllTy _ _) + = getPprStyle $ \ sty -> + maybeParen ctxt_prec fUN_PREC $ + if ifaceStyle sty then + sep [ ptext SLIT("__forall") <+> brackets pp_tyvars <+> ptext SLIT("=>"), + ppr_ty env tOP_PREC rho + ] + else + -- The type checker occasionally prints a type in an error message, + -- and it had better come out looking like a user type + sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), + ppr_theta theta, + ppr_ty env tOP_PREC tau + ] + where + (tyvars, rho) = splitForAllTys ty -- don't treat theta specially any more (KSW 1999-04) + (theta, tau) = splitRhoTy rho + + pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars) + + ppr_theta [] = empty + ppr_theta theta = parens (hsep (punctuate comma (map ppr_pred theta))) + <+> ptext SLIT("=>") + + ppr_pred (Class clas tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys) + ppr_pred (IParam n ty) = hsep [{- char '?' <> -} ppr n, text "::", + ppr_ty env tYCON_PREC ty] + +ppr_ty env ctxt_prec (FunTy ty1 ty2) + = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest ty2)) + -- we don't want to lose usage annotations or synonyms, + -- so we mustn't use splitFunTys here. where - (ty1:ty2:_) = arg_tys + pp_rest (FunTy ty1 ty2) = pp_codom ty1 : pp_rest ty2 + pp_rest ty = [pp_codom ty] + pp_codom ty = ptext SLIT("->") <+> ppr_ty env fUN_PREC ty -ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys - | isTupleTyCon tycon - && not (codeStyle (pStyle env)) -- no magic in that case - && length arg_tys == tyConArity tycon -- no magic if partially applied - = parens arg_tys_w_commas - where - arg_tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) arg_tys)) +ppr_ty env ctxt_prec (AppTy ty1 ty2) + = maybeParen ctxt_prec tYCON_PREC $ + ppr_ty env tOP_PREC ty1 <+> ppr_ty env tYCON_PREC ty2 -ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys - | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey - = ASSERT(length arg_tys == 1) - brackets (ppr_ty env tOP_PREC ty1) - where - (ty1:_) = arg_tys +ppr_ty env ctxt_prec (NoteTy (SynNote ty) expansion) + = ppr_ty env ctxt_prec ty +-- = ppr_ty env ctxt_prec expansion -- if we don't want to see syntys -ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys - = ppr_app env ctxt_prec (ppr_tycon env tycon) arg_tys - -ppr_corner env ctxt_prec (TyVarTy tyvar) arg_tys - = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys - +ppr_ty env ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty -ppr_app env ctxt_prec pp_fun [] - = pp_fun -ppr_app env ctxt_prec pp_fun arg_tys - = maybeParen ctxt_prec tYCON_PREC (hsep [pp_fun, arg_tys_w_spaces]) +ppr_ty env ctxt_prec ty@(NoteTy (UsgForAll _) _) + = maybeParen ctxt_prec fUN_PREC $ + sep [ ptext SLIT("__fuall") <+> brackets pp_uvars <+> ptext SLIT("=>"), + ppr_ty env tOP_PREC sigma + ] where - arg_tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) arg_tys) + (uvars,sigma) = splitUsForAllTys ty + pp_uvars = hsep (map ppr uvars) + +ppr_ty env ctxt_prec (NoteTy (UsgNote u) ty) + = maybeParen ctxt_prec tYCON_PREC $ + ptext SLIT("__u") <+> ppr u <+> ppr_ty env tYCON_PREC ty +ppr_ty env ctxt_prec (NoteTy (IPNote nm) ty) + = braces (ppr_pred env (IParam nm ty)) ppr_theta env [] = empty -ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta))) +ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_pred env) theta))) -ppr_dict env ctxt_prec (clas, ty) - = maybeParen ctxt_prec tYCON_PREC - (hsep [ppr_class env clas, ppr_ty env tYCON_PREC ty]) +ppr_pred env (Class clas tys) = ppr clas <+> + hsep (map (ppr_ty env tYCON_PREC) tys) +ppr_pred env (IParam n ty) = hsep [char '?' <> ppr n, text "::", + ppr_ty env tYCON_PREC ty] + +{- +ppr_dict env ctxt (clas, tys) = ppr clas <+> + hsep (map (ppr_ty env tYCON_PREC) tys) +-} \end{code} \begin{code} - -- This one uses only "ppr" -init_ppr_env sty - = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b +pprTyEnv = initPprEnv b (Just ppr) b (Just (\site -> pprTyVarBndr)) b where b = panic "PprType:init_ppr_env" - - -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types -init_ppr_env_type sty - = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b - where - b = panic "PprType:init_ppr_env" - -ppr_tycon env tycon = ppr (pStyle env) tycon -ppr_class env clas = ppr (pStyle env) clas \end{code} -%************************************************************************ -%* * -\subsection[TyVar]{@TyVar@} -%* * -%************************************************************************ - \begin{code} -pprGenTyVar sty (TyVar uniq kind maybe_name usage) - = case maybe_name of - -- If the tyvar has a name we can safely use just it, I think - Just n -> pprOccName sty (getOccName n) <> debug_extra - Nothing -> pp_kind <> pprUnique uniq - where - pp_kind = case kind of - TypeKind -> char 'o' - BoxedTypeKind -> char 't' - UnboxedTypeKind -> char 'u' - ArrowKind _ _ -> char 'a' - - debug_extra = case sty of - PprDebug -> pp_debug - PprShowAll -> pp_debug - other -> empty - - pp_debug = text "_" <> pp_kind <> pprUnique uniq +instance Outputable UsageAnn where + ppr UsOnce = ptext SLIT("-") + ppr UsMany = ptext SLIT("!") + ppr (UsVar uv) = ppr uv \end{code} -We print type-variable binders with their kinds in interface files. - -\begin{code} -pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage) - | not (isBoxedTypeKind kind) - = hcat [pprGenTyVar sty tyvar, text " :: ", pprParendKind kind] - -- See comments with ppDcolon in PprCore.lhs - -pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar -\end{code} %************************************************************************ %* * -\subsection[TyCon]{@TyCon@} +\subsection[TyVar]{@TyVar@} %* * %************************************************************************ -ToDo; all this is suspiciously like getOccName! +We print type-variable binders with their kinds in interface files, +and when in debug mode. \begin{code} -showTyCon :: PprStyle -> TyCon -> String -showTyCon sty tycon = show (pprTyCon sty tycon) +pprTyVarBndr tyvar + = getPprStyle $ \ sty -> + if (ifaceStyle sty || debugStyle sty) && kind /= boxedTypeKind then + hsep [ppr tyvar, dcolon, pprParendKind kind] + -- See comments with ppDcolon in PprCore.lhs + else + ppr tyvar + where + kind = tyVarKind tyvar -pprTyCon :: PprStyle -> TyCon -> Doc -pprTyCon sty tycon = ppr sty (getName tycon) +pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars) \end{code} - %************************************************************************ %* * \subsection{Mumbo jumbo} %* * %************************************************************************ -\begin{code} - -- Shallowly magical; converts a type into something - -- vaguely close to what can be used in C identifier. - -- Produces things like what we have in mkCompoundName, - -- which can be "dot"ted together... - -getTypeString :: Type -> FAST_STRING - -getTypeString ty - = case (splitAppTys ty) of { (tc, args) -> - _CONCAT_ (do_tc tc : map do_arg_ty args) } - where - do_tc (TyConTy tc _) = nameString (getName tc) - do_tc (SynTy _ _ ty) = do_tc ty - do_tc other = --pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $ - (_PK_ (show (pprType PprForC other))) - - do_arg_ty (TyConTy tc _) = nameString (getName tc) - do_arg_ty (TyVarTy tv) = _PK_ (show (ppr PprForC tv)) - do_arg_ty (SynTy _ _ ty) = do_arg_ty ty - do_arg_ty other = --pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $ - _PK_ (show (pprType PprForC other)) - - -- PprForC expands type synonyms as it goes; - -- it also forces consistent naming of tycons - -- (e.g., can't have both "(,) a b" and "(a,b)": - -- must be consistent! - -specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING -specMaybeTysSuffix ty_maybes - = panic "PprType.specMaybeTysSuffix" -{- LATER: - = let - ty_strs = concat (map typeMaybeString ty_maybes) - dotted_tys = [ _CONS_ '.' str | str <- ty_strs ] - in - _CONCAT_ dotted_tys --} -\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 _ -> getOccString tycon - SynTy tycon _ _ -> getOccString tycon - DictTy _ _ _ -> "dict" - ForAllTy _ ty -> getTyDescription ty - _ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty) + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + FunTy _ res -> '-' : '>' : fun_result res + TyConApp tycon _ -> getOccString tycon + NoteTy (FTVNote _) ty -> getTyDescription ty + NoteTy (SynNote ty1) _ -> getTyDescription ty1 + NoteTy (UsgNote _) ty -> getTyDescription ty + ForAllTy _ ty -> getTyDescription ty } where - fun_result (FunTy _ res _) = '>' : fun_result res - fun_result other = getTyDescription other -\end{code} - - - -%************************************************************************ -%* * -\subsection{Renumbering types} -%* * -%************************************************************************ - -We tend to {\em renumber} everything before printing, so that we get -consistent Uniques on everything from run to run. - - -\begin{code} -nmbrGlobalType :: Type -> Type -- Renumber a top-level type -nmbrGlobalType ty = nmbrType (\tyvar -> tyvar) (\uvar -> uvar) initTyVarUnique ty - -nmbrType :: (TyVar -> TyVar) -> (UVar -> UVar) -- Mapping for free vars - -> Unique - -> Type - -> Type - -nmbrType tyvar_env uvar_env uniq ty - = initNmbr tyvar_env uvar_env uniq (nmbrTy ty) - -nmbrTy :: Type -> NmbrM Type - -nmbrTy (TyVarTy tv) - = lookupTyVar tv `thenNmbr` \ new_tv -> - returnNmbr (TyVarTy new_tv) - -nmbrTy (AppTy t1 t2) - = nmbrTy t1 `thenNmbr` \ new_t1 -> - nmbrTy t2 `thenNmbr` \ new_t2 -> - returnNmbr (AppTy new_t1 new_t2) - -nmbrTy (TyConTy tc use) - = nmbrUsage use `thenNmbr` \ new_use -> - returnNmbr (TyConTy tc new_use) - -nmbrTy (SynTy tc args expand) - = mapNmbr nmbrTy args `thenNmbr` \ new_args -> - nmbrTy expand `thenNmbr` \ new_expand -> - returnNmbr (SynTy tc new_args new_expand) - -nmbrTy (ForAllTy tv ty) - = addTyVar tv $ \ new_tv -> - nmbrTy ty `thenNmbr` \ new_ty -> - returnNmbr (ForAllTy new_tv new_ty) - -nmbrTy (ForAllUsageTy u us ty) - = addUVar u $ \ new_u -> - mapNmbr lookupUVar us `thenNmbr` \ new_us -> - nmbrTy ty `thenNmbr` \ new_ty -> - returnNmbr (ForAllUsageTy new_u new_us new_ty) - -nmbrTy (FunTy t1 t2 use) - = nmbrTy t1 `thenNmbr` \ new_t1 -> - nmbrTy t2 `thenNmbr` \ new_t2 -> - nmbrUsage use `thenNmbr` \ new_use -> - returnNmbr (FunTy new_t1 new_t2 new_use) - -nmbrTy (DictTy c ty use) - = nmbrTy ty `thenNmbr` \ new_ty -> - nmbrUsage use `thenNmbr` \ new_use -> - returnNmbr (DictTy c new_ty new_use) - - - -lookupTyVar tyvar (NmbrEnv tv_fn tv_env _ _) uniq - = (uniq, tyvar') - where - tyvar' = case lookupUFM tv_env tyvar of - Just tyvar' -> tyvar' - Nothing -> tv_fn tyvar - -addTyVar tv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u - = m tv' nenv u' - where - nenv = NmbrEnv f_tv tv_ufm' f_uv uv_ufm - tv_ufm' = addToUFM tv_ufm tv tv' - tv' = cloneTyVar tv u - u' = incrUnique u -\end{code} - -Usage stuff - -\begin{code} -nmbrUsage (UsageVar v) - = lookupUVar v `thenNmbr` \ v' -> - returnNmbr (UsageVar v) - -nmbrUsage u = returnNmbr u - - -lookupUVar uvar (NmbrEnv _ _ uv_fn uv_env) uniq - = (uniq, uvar') - where - uvar' = case lookupUFM uv_env uvar of - Just uvar' -> uvar' - Nothing -> uv_fn uvar - -addUVar uv m (NmbrEnv f_tv tv_ufm f_uv uv_ufm) u - = m uv' nenv u' - where - nenv = NmbrEnv f_tv tv_ufm f_uv uv_ufm' - uv_ufm' = addToUFM uv_ufm uv uv' - uv' = cloneUVar uv u - u' = incrUnique u + fun_result (FunTy _ res) = '>' : fun_result res + fun_result other = getTyDescription other \end{code} -Monad stuff \begin{code} -data NmbrEnv - = NmbrEnv (TyVar -> TyVar) (UniqFM TyVar) -- Global and local map for tyvars - (UVar -> UVar) (UniqFM UVar) -- ... for usage vars - -type NmbrM a = NmbrEnv -> Unique -> (Unique, a) -- Unique is name supply - -initNmbr :: (TyVar -> TyVar) -> (UVar -> UVar) -> Unique -> NmbrM a -> a -initNmbr tyvar_env uvar_env uniq m - = let - init_nmbr_env = NmbrEnv tyvar_env emptyUFM uvar_env emptyUFM - in - snd (m init_nmbr_env uniq) - -returnNmbr x nenv u = (u, x) - -thenNmbr m k nenv u - = let - (u', res) = m nenv u - in - k res nenv u' - - -mapNmbr f [] = returnNmbr [] -mapNmbr f (x:xs) - = f x `thenNmbr` \ r -> - mapNmbr f xs `thenNmbr` \ rs -> - returnNmbr (r:rs) +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 splitTyConApp_maybe ty of + Nothing -> if maybeToBool (splitFunTy_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' + 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}