X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FPprType.lhs;h=d0fd5db2e78f9c8d3453666a57f481e320e025ec;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=3762e632a7a03e91e0d311c0228b8b8b78dd1010;hpb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;p=ghc-hetmet.git diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 3762e63..d0fd5db 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -1,18 +1,16 @@ % -% (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, + pprTyVarBndr, pprTyVarBndrs, + + getTyDescription, nmbrType, nmbrGlobalType ) where @@ -21,54 +19,65 @@ module PprType( -- 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 Type ( GenType(..), TyNote(..), Kind, Type, ThetaType, + splitFunTys, splitDictTy_maybe, + splitForAllTys, splitSigmaTy, splitRhoTy, + boxedTypeKind + ) +import Var ( GenTyVar, TyVar, tyVarKind, + tyVarName, setTyVarName + ) +import VarEnv +import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon, tyConArity ) import Class ( Class ) -import Kind ( GenKind(..), isBoxedTypeKind, pprParendKind ) -- others: -import CmdLineOpts ( opt_PprUserLength ) import Maybes ( maybeToBool ) -import Name ( nameString, pprOccName, getOccString, OccName, NamedThing(..) ) +import Name ( getOccString, setNameVisibility, NamedThing(..) ) import Outputable import PprEnv -import BasicTypes ( Unused ) -import UniqFM ( UniqFM, addToUFM, emptyUFM, lookupUFM ) -import Unique ( Unique, Uniquable(..), pprUnique, +import Unique ( Unique, Uniquable(..), incrUnique, listTyConKey, initTyVarUnique ) import Util \end{code} -\begin{code} -instance Outputable (GenType flexi) where - ppr ty = pprGenType ty +%************************************************************************ +%* * +\subsection{The external interface} +%* * +%************************************************************************ -instance Outputable TyCon where - ppr tycon = pprTyCon tycon +@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. -instance Outputable Class where - -- we use pprIfaceClass for printing in interfaces - ppr clas = ppr (getName clas) +\begin{code} +pprType, pprParendType :: GenType flexi -> SDoc +pprType ty = ppr_ty pprTyEnv tOP_PREC ty +pprParendType ty = ppr_ty pprTyEnv tYCON_PREC ty -instance Outputable (GenTyVar flexi) where - ppr tv = pprGenTyVar tv +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType --- and two SPECIALIZEd ones: -{- -instance Outputable {-Type, i.e.:-}(GenType Unused) where - ppr ty = pprGenType ty +pprConstraint :: Class -> [GenType flexi] -> SDoc +pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys) -instance Outputable {-TyVar, i.e.:-}(GenTyVar Unused) where - ppr ty = pprGenTyVar ty --} +pprTheta :: ThetaType -> SDoc +pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta))) + where + ppr_dict (c,tys) = pprConstraint c tys + +instance Outputable (GenType flexi) where + ppr ty = pprType ty \end{code} + %************************************************************************ %* * -\subsection[Type]{@Type@} +\subsection{Pretty printing} %* * %************************************************************************ @@ -93,53 +102,29 @@ 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 +ppr_ty :: PprEnv (GenTyVar flexi) flexi -> Int -> GenType flexi -> SDoc ppr_ty env ctxt_prec (TyVarTy tyvar) = pTyVarO env tyvar - -- TUPLE CASE + -- TUPLE CASE (boxed and unboxed) ppr_ty env ctxt_prec (TyConApp tycon tys) | isTupleTyCon tycon - && length tys == tyConArity tycon -- no magic if partially applied + && length tys == tyConArity tycon -- no magic if partially applied = parens tys_w_commas + + | isUnboxedTupleTyCon tycon + && length tys == tyConArity tycon -- no magic if partially applied + = parens (char '#' <+> tys_w_commas <+> char '#') where - tys_w_commas = hsep (punctuate comma (map (ppr_ty env tOP_PREC) tys)) + tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys)) -- LIST CASE ppr_ty env ctxt_prec (TyConApp tycon [ty]) - | uniqueOf tycon == listTyConKey + | getUnique tycon == listTyConKey = brackets (ppr_ty env tOP_PREC ty) -- DICTIONARY CASE, prints {C a} @@ -154,40 +139,34 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) -- NO-ARGUMENT CASE (=> no parens) ppr_ty env ctxt_prec (TyConApp tycon []) - = ppr_tycon env tycon + = 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]) + = maybeParen ctxt_prec tYCON_PREC (hsep [ppr tycon, tys_w_spaces]) where tys_w_spaces = hsep (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 userStyle sty then + sep [ ptext SLIT("forall"), pp_tyvars, ptext SLIT("."), pp_maybe_ctxt, pp_body ] + else + sep [ ptext SLIT("__forall"), brackets pp_tyvars, pp_ctxt, pp_body ] + where + (tyvars, rho_ty) = splitForAllTys ty + (theta, body_ty) = splitRhoTy rho_ty - 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) + pp_body = ppr_ty env tOP_PREC body_ty - 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 - ] + pp_maybe_ctxt | null theta = empty + | otherwise = pp_ctxt - else if null theta then - ppr_ty env ctxt_prec body_ty + pp_ctxt = ppr_theta env theta <+> ptext SLIT("=>") - else - maybeParen ctxt_prec fUN_PREC $ - sep [ppr_theta env theta, ptext SLIT("=>"), pp_body] ppr_ty env ctxt_prec (FunTy ty1 ty2) -- We fiddle the precedences passed to left/right branches, @@ -201,31 +180,22 @@ 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 (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty + ppr_theta env [] = empty ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta))) -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" - -ppr_tycon env tycon = ppr tycon -ppr_class env clas = ppr clas \end{code} %************************************************************************ @@ -234,53 +204,23 @@ ppr_class env clas = ppr clas %* * %************************************************************************ -\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 + hcat [ppr tyvar, text " :: ", 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 +230,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 +241,8 @@ 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 ForAllTy _ ty -> getTyDescription ty } where @@ -309,7 +251,6 @@ getTyDescription ty \end{code} - %************************************************************************ %* * \subsection{Renumbering types} @@ -322,10 +263,11 @@ 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 +nmbrGlobalType ty = nmbrType emptyVarEnv initTyVarUnique ty -nmbrType :: (TyVar -> TyVar) -- Mapping for free vars - -> Unique +nmbrType :: TyVarEnv Type -- Substitution + -> Unique -- This unique and its successors are not + -- free in the range of the substitution -> Type -> Type @@ -335,8 +277,7 @@ nmbrType tyvar_env uniq ty nmbrTy :: Type -> NmbrM Type nmbrTy (TyVarTy tv) - = lookupTyVar tv `thenNmbr` \ new_tv -> - returnNmbr (TyVarTy new_tv) + = lookupTyVar tv nmbrTy (AppTy t1 t2) = nmbrTy t1 `thenNmbr` \ new_t1 -> @@ -344,13 +285,15 @@ nmbrTy (AppTy t1 t2) returnNmbr (AppTy new_t1 new_t2) nmbrTy (TyConApp tc tys) - = nmbrTys tys `thenNmbr` \ new_tys -> + = mapNmbr nmbrTy tys `thenNmbr` \ new_tys -> returnNmbr (TyConApp tc new_tys) -nmbrTy (SynTy ty1 ty2) +nmbrTy (NoteTy (SynNote ty1) ty2) = nmbrTy ty1 `thenNmbr` \ new_ty1 -> nmbrTy ty2 `thenNmbr` \ new_ty2 -> - returnNmbr (SynTy new_ty1 new_ty2) + returnNmbr (NoteTy (SynNote new_ty1) new_ty2) + +nmbrTy (NoteTy (FTVNote _) ty2) = nmbrTy ty2 nmbrTy (ForAllTy tv ty) = addTyVar tv $ \ new_tv -> @@ -363,38 +306,29 @@ nmbrTy (FunTy t1 t2) returnNmbr (FunTy new_t1 new_t2) -nmbrTys tys = mapNmbr nmbrTy tys - -lookupTyVar tyvar (NmbrEnv tv_fn tv_env) uniq - = (uniq, tyvar') +lookupTyVar tyvar env uniq + = (uniq, ty) where - tyvar' = case lookupUFM tv_env tyvar of - Just tyvar' -> tyvar' - Nothing -> tv_fn tyvar + ty = case lookupVarEnv env tyvar of + Just ty -> ty + Nothing -> TyVarTy tyvar -addTyVar tv m (NmbrEnv f_tv tv_ufm) u - = m tv' nenv u' +addTyVar tv m env u + = m tv' env' u' where - nenv = NmbrEnv f_tv tv_ufm' - tv_ufm' = addToUFM tv_ufm tv tv' - tv' = cloneTyVar tv u - u' = incrUnique u + env' = extendVarEnv env tv (TyVarTy tv') + tv' = setTyVarName tv (setNameVisibility Nothing u (tyVarName tv)) + 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 +type NmbrM a = TyVarEnv Type -> 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) +initNmbr :: TyVarEnv Type -> Unique -> NmbrM a -> a +initNmbr env uniq m + = snd (m env uniq) returnNmbr x nenv u = (u, x)