X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FPprType.lhs;h=db54a7da6011ec6b26ab03752dbaee29d1415139;hb=461f1fb54915b564141ec07ce6f2ea284dc6cea8;hp=3762e632a7a03e91e0d311c0228b8b8b78dd1010;hpb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;p=ghc-hetmet.git diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 3762e63..db54a7d 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -1,74 +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} module PprType( - GenTyVar, pprGenTyVar, pprTyVarBndr, pprTyVarBndrs, - TyCon, pprTyCon, showTyCon, - GenType, - pprGenType, pprParendGenType, + pprKind, pprParendKind, pprType, pprParendType, - pprMaybeTy, - getTyDescription, - pprConstraint, pprTheta, + pprConstraint, pprPred, pprTheta, + pprTyVarBndr, pprTyVarBndrs, - nmbrType, nmbrGlobalType + -- Junk + getTyDescription, showTypeCategory ) where #include "HsVersions.h" -- friends: -- (PprType can see all the representations it's trying to print) -import Type ( GenType(..), Type, ThetaType, splitFunTys, splitDictTy_maybe, - splitForAllTys, splitSigmaTy, splitRhoTy, splitAppTys ) -import TyVar ( GenTyVar(..), TyVar, cloneTyVar ) -import TyCon ( TyCon, NewOrData, isFunTyCon, isTupleTyCon, tyConArity ) -import Class ( Class ) -import Kind ( GenKind(..), isBoxedTypeKind, pprParendKind ) +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 CmdLineOpts ( opt_PprUserLength ) import Maybes ( maybeToBool ) -import Name ( nameString, pprOccName, getOccString, OccName, NamedThing(..) ) +import Name ( getOccString, NamedThing(..) ) import Outputable import PprEnv -import BasicTypes ( Unused ) -import UniqFM ( UniqFM, addToUFM, emptyUFM, lookupUFM ) -import Unique ( Unique, Uniquable(..), 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 Outputable (GenType flexi) where - ppr ty = pprGenType ty +pprType, pprParendType :: Type -> SDoc +pprType ty = ppr_ty pprTyEnv tOP_PREC ty +pprParendType ty = ppr_ty pprTyEnv tYCON_PREC ty -instance Outputable TyCon where - ppr tycon = pprTyCon tycon +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType -instance Outputable Class where - -- we use pprIfaceClass for printing in interfaces - ppr clas = ppr (getName clas) +pprPred :: PredType -> SDoc +pprPred (Class clas tys) = pprConstraint clas tys +pprPred (IParam n ty) = hsep [ppr n, ptext SLIT("::"), ppr ty] -instance Outputable (GenTyVar flexi) where - ppr tv = pprGenTyVar tv +pprConstraint :: Class -> [Type] -> SDoc +pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys) --- and two SPECIALIZEd ones: -{- -instance Outputable {-Type, i.e.:-}(GenType Unused) where - ppr ty = pprGenType ty +pprTheta :: ThetaType -> SDoc +pprTheta theta = parens (hsep (punctuate comma (map pprPred theta))) -instance Outputable {-TyVar, i.e.:-}(GenTyVar Unused) where - ppr ty = pprGenTyVar ty --} +instance Outputable Type where + ppr ty = pprType ty \end{code} + %************************************************************************ %* * -\subsection[Type]{@Type@} +\subsection{Pretty printing} %* * %************************************************************************ @@ -93,194 +109,175 @@ 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 :: GenType flexi -> SDoc - -pprGenType ty = ppr_ty init_ppr_env tOP_PREC ty -pprParendGenType ty = ppr_ty init_ppr_env tYCON_PREC ty - -pprType, pprParendType :: Type -> SDoc -pprType ty = ppr_ty init_ppr_env_type tOP_PREC ty -pprParendType ty = ppr_ty init_ppr_env_type tYCON_PREC ty - -pprConstraint :: Class -> [GenType flexi] -> SDoc -pprConstraint clas tys = hsep [ppr clas, hsep (map (pprParendGenType) tys)] - -pprTheta :: ThetaType -> SDoc -pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta))) - where - ppr_dict (c,tys) = pprConstraint c tys - -pprMaybeTy :: Maybe (GenType flexi) -> SDoc -pprMaybeTy Nothing = char '*' -pprMaybeTy (Just ty) = pprParendGenType ty -\end{code} - \begin{code} -ppr_ty :: PprEnv flexi bndr occ -> Int - -> GenType flexi - -> SDoc - +ppr_ty :: PprEnv TyVar -> Int -> Type -> SDoc ppr_ty env ctxt_prec (TyVarTy tyvar) = pTyVarO env tyvar - -- TUPLE CASE -ppr_ty env ctxt_prec (TyConApp tycon tys) +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 + && length tys == tyConArity tycon -- no magic if partially applied = parens tys_w_commas - where - tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) tys)) + + | isUnboxedTupleTyCon tycon + && length tys == tyConArity tycon -- no magic if partially applied + = parens (char '#' <+> tys_w_commas <+> char '#') -- LIST CASE -ppr_ty env ctxt_prec (TyConApp tycon [ty]) - | uniqueOf tycon == listTyConKey - = brackets (ppr_ty env tOP_PREC ty) + | tycon_uniq == listTyConKey && n_tys == 1 + = brackets (ppr_ty env tOP_PREC ty1) -- 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 -ppr_ty env ctxt_prec ty@(TyConApp tycon tys) - | maybeToBool maybe_dict - = braces (ppr_dict env tYCON_PREC ctys) - where - Just ctys = maybe_dict - maybe_dict = splitDictTy_maybe ty - + | maybeToBool maybe_pred + = braces (ppr_pred env pred) + -- NO-ARGUMENT CASE (=> no parens) -ppr_ty env ctxt_prec (TyConApp tycon []) - = ppr_tycon env tycon + | null tys + = ppr tycon -- GENERAL CASE -ppr_ty env ctxt_prec (TyConApp tycon tys) - = maybeParen ctxt_prec tYCON_PREC (hsep [ppr_tycon env tycon, tys_w_spaces]) + | otherwise + = maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces]) + where - tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) tys) + 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) + ppr_ty env ctxt_prec ty@(ForAllTy _ _) = getPprStyle $ \ sty -> - let - (tyvars, rho_ty) = splitForAllTys ty - (theta, body_ty) | show_context = splitRhoTy rho_ty - | otherwise = ([], rho_ty) + 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 = brackets (hsep (map (pTyVarB env) tyvars)) - pp_body = ppr_ty env tOP_PREC body_ty + pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars) - show_forall = not (userStyle sty) - show_context = ifaceStyle sty || userStyle sty - in - if show_forall then - maybeParen ctxt_prec fUN_PREC $ - sep [ ptext SLIT("_forall_"), pp_tyvars, - ppr_theta env theta, ptext SLIT("=>"), pp_body - ] - - else if null theta then - ppr_ty env ctxt_prec body_ty + ppr_theta [] = empty + ppr_theta theta = parens (hsep (punctuate comma (map ppr_pred theta))) + <+> ptext SLIT("=>") - else - maybeParen ctxt_prec fUN_PREC $ - sep [ppr_theta env theta, ptext SLIT("=>"), pp_body] + 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) - -- 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)) + = 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 - (arg_tys, result_ty) = splitFunTys ty2 - pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ] + 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_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_ty env ctxt_prec (SynTy ty expansion) +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_ty env ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty + +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 + (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_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_class env clas <+> +{- +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 - = initPprEnv b b b b (Just ppr) (Just ppr) b b b - where - b = panic "PprType:init_ppr_env" - - -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types -init_ppr_env_type - = initPprEnv b b b b (Just pprTyVarBndr) (Just ppr) b b b +pprTyEnv = initPprEnv b b (Just ppr) b (Just (\site -> pprTyVarBndr)) b where b = panic "PprType:init_ppr_env" +\end{code} -ppr_tycon env tycon = ppr tycon -ppr_class env clas = ppr clas +\begin{code} +instance Outputable UsageAnn where + ppr UsOnce = ptext SLIT("-") + ppr UsMany = ptext SLIT("!") + ppr (UsVar uv) = ppr uv \end{code} + %************************************************************************ %* * \subsection[TyVar]{@TyVar@} %* * %************************************************************************ -\begin{code} -pprGenTyVar (TyVar uniq kind maybe_name _) - = case maybe_name of - -- If the tyvar has a name we can safely use just it, I think - Just n -> pprOccName (getOccName n) <> ifPprDebug pp_debug - Nothing -> pprUnique uniq - where - pp_debug = text "_" <> pp_kind <> pprUnique uniq - - pp_kind = case kind of - TypeKind -> char 'o' - BoxedTypeKind -> char 't' - UnboxedTypeKind -> char 'u' - ArrowKind _ _ -> char 'a' -\end{code} - -We print type-variable binders with their kinds in interface files. +We print type-variable binders with their kinds in interface files, +and when in debug mode. \begin{code} -pprTyVarBndr tyvar@(TyVar uniq kind name _) +pprTyVarBndr tyvar = getPprStyle $ \ sty -> - if ifaceStyle sty && not (isBoxedTypeKind kind) then - hcat [pprGenTyVar tyvar, text " :: ", pprParendKind kind] - -- See comments with ppDcolon in PprCore.lhs + if (ifaceStyle sty || debugStyle sty) && kind /= boxedTypeKind then + hsep [ppr tyvar, dcolon, pprParendKind kind] + -- See comments with ppDcolon in PprCore.lhs else - pprGenTyVar tyvar + ppr tyvar + where + kind = tyVarKind tyvar pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars) \end{code} -%************************************************************************ -%* * -\subsection[TyCon]{@TyCon@} -%* * -%************************************************************************ - -ToDo; all this is suspiciously like getOccName! - -\begin{code} -showTyCon :: TyCon -> String -showTyCon tycon = showSDoc (pprTyCon tycon) - -pprTyCon :: TyCon -> SDoc -pprTyCon tycon = ppr (getName tycon) -\end{code} - - %************************************************************************ %* * @@ -290,6 +287,7 @@ pprTyCon tycon = ppr (getName tycon) Grab a name for the type. This is used to determine the type description for profiling. + \begin{code} getTyDescription :: Type -> String @@ -300,7 +298,9 @@ getTyDescription ty AppTy fun _ -> getTyDescription fun FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon - SynTy ty1 _ -> getTyDescription ty1 + NoteTy (FTVNote _) ty -> getTyDescription ty + NoteTy (SynNote ty1) _ -> getTyDescription ty1 + NoteTy (UsgNote _) ty -> getTyDescription ty ForAllTy _ ty -> getTyDescription ty } where @@ -309,105 +309,53 @@ getTyDescription ty \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) initTyVarUnique ty - -nmbrType :: (TyVar -> TyVar) -- Mapping for free vars - -> Unique - -> Type - -> Type - -nmbrType tyvar_env uniq ty - = initNmbr tyvar_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 (TyConApp tc tys) - = nmbrTys tys `thenNmbr` \ new_tys -> - returnNmbr (TyConApp tc new_tys) - -nmbrTy (SynTy ty1 ty2) - = nmbrTy ty1 `thenNmbr` \ new_ty1 -> - nmbrTy ty2 `thenNmbr` \ new_ty2 -> - returnNmbr (SynTy new_ty1 new_ty2) - -nmbrTy (ForAllTy tv ty) - = addTyVar tv $ \ new_tv -> - nmbrTy ty `thenNmbr` \ new_ty -> - returnNmbr (ForAllTy new_tv new_ty) - -nmbrTy (FunTy t1 t2) - = nmbrTy t1 `thenNmbr` \ new_t1 -> - nmbrTy t2 `thenNmbr` \ new_t2 -> - returnNmbr (FunTy new_t1 new_t2) - - -nmbrTys tys = mapNmbr nmbrTy tys - -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) u - = m tv' nenv u' - where - nenv = NmbrEnv f_tv tv_ufm' - tv_ufm' = addToUFM tv_ufm tv tv' - tv' = cloneTyVar tv u - u' = incrUnique u -\end{code} - -Monad stuff - -\begin{code} -data NmbrEnv - = NmbrEnv (TyVar -> TyVar) (UniqFM TyVar) -- Global and local map for tyvars - -type NmbrM a = NmbrEnv -> Unique -> (Unique, a) -- Unique is name supply - -initNmbr :: (TyVar -> TyVar) -> Unique -> NmbrM a -> a -initNmbr tyvar_env uniq m - = let - init_nmbr_env = NmbrEnv tyvar_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}