X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FPprType.lhs;h=273a06775001ed1a0adccbb7958f6a09cbb7fba3;hb=8ea5c86c1424997c7c9f836dbccd87956811bc29;hp=637ea1f812ba5e49004ab5078633924ec796be8a;hpb=5f67848a9c686f64bd4960a40a0e109f286df74b;p=ghc-hetmet.git diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 637ea1f..273a067 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -7,7 +7,7 @@ module PprType( pprKind, pprParendKind, pprType, pprParendType, - pprConstraint, pprPred, pprTheta, + pprPred, pprTheta, pprClassPred, pprTyVarBndr, pprTyVarBndrs, -- Junk @@ -18,28 +18,27 @@ module PprType( -- friends: -- (PprType can see all the representations it's trying to print) -import TypeRep ( Type(..), TyNote(..), Kind, UsageAnn(..), - boxedTypeKind, - ) -- friend +import TypeRep ( Type(..), TyNote(..), Kind, liftedTypeKind ) -- friend import Type ( PredType(..), ThetaType, splitPredTy_maybe, splitForAllTys, splitSigmaTy, splitRhoTy, - isDictTy, splitTyConApp_maybe, splitFunTy_maybe, - splitUsForAllTys, predRepTy + isPredTy, isDictTy, splitTyConApp_maybe, splitFunTy_maybe, + predRepTy, isUTyVar ) import Var ( TyVar, tyVarKind ) -import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, +import Class ( Class ) +import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, tupleTyConBoxity, maybeTyConSingleCon, isEnumerationTyCon, - tyConArity + tyConArity, tyConName ) -import Class ( Class ) -- others: +import CmdLineOpts ( opt_PprStyle_RawTypes ) import Maybes ( maybeToBool ) import Name ( getOccString, getOccName ) import Outputable -import PprEnv import Unique ( Uniquable(..) ) +import BasicTypes ( tupleParens ) import PrelNames -- quite a few *Keys \end{code} @@ -56,20 +55,20 @@ works just by setting the initial context precedence very high. \begin{code} pprType, pprParendType :: Type -> SDoc -pprType ty = ppr_ty pprTyEnv tOP_PREC ty -pprParendType ty = ppr_ty pprTyEnv tYCON_PREC ty +pprType ty = ppr_ty tOP_PREC ty +pprParendType ty = ppr_ty 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 [ptext SLIT("?") <> ppr n, - ptext SLIT("::"), ppr ty] +pprPred (ClassP clas tys) = pprClassPred clas tys +pprPred (IParam n ty) = hsep [ptext SLIT("?") <> ppr n, + ptext SLIT("::"), ppr ty] -pprConstraint :: Class -> [Type] -> SDoc -pprConstraint clas tys = ppr clas <+> hsep (map pprParendType tys) +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = ppr clas <+> hsep (map pprParendType tys) pprTheta :: ThetaType -> SDoc pprTheta theta = parens (hsep (punctuate comma (map pprPred theta))) @@ -100,9 +99,9 @@ The precedence levels are: \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 @@ -110,11 +109,11 @@ maybeParen ctxt_prec inner_prec pretty \end{code} \begin{code} -ppr_ty :: PprEnv TyVar -> Int -> Type -> SDoc -ppr_ty env ctxt_prec (TyVarTy tyvar) - = pTyVarO env tyvar +ppr_ty :: Int -> Type -> SDoc +ppr_ty ctxt_prec (TyVarTy tyvar) + = ppr tyvar -ppr_ty env ctxt_prec ty@(TyConApp tycon tys) +ppr_ty ctxt_prec ty@(TyConApp tycon tys) -- KIND CASE; it's of the form (Type x) | tycon `hasKey` typeConKey && n_tys == 1 = -- For kinds, print (Type x) as just x if x is a @@ -124,25 +123,26 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) TyConApp bx [] -> ppr (getOccName bx) -- Always unqualified other -> maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces]) - + + -- USAGE CASE + | (tycon `hasKey` usOnceTyConKey || tycon `hasKey` usManyTyConKey) && n_tys == 0 + = -- For usages (! and .), always print bare OccName, without pkg/mod/uniq + ppr (getOccName (tyConName tycon)) + -- TUPLE CASE (boxed and unboxed) | isTupleTyCon tycon && 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 '#') + = tupleParens (tupleTyConBoxity tycon) tys_w_commas -- LIST CASE | tycon `hasKey` listTyConKey && n_tys == 1 - = brackets (ppr_ty env tOP_PREC ty1) + = brackets (ppr_ty 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 | maybeToBool maybe_pred - = braces (ppr_pred env pred) + = braces (pprPred pred) -- NO-ARGUMENT CASE (=> no parens) | null tys @@ -157,80 +157,60 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon 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) + tys_w_commas = sep (punctuate comma (map (ppr_ty tOP_PREC) tys)) + tys_w_spaces = sep (map (ppr_ty tYCON_PREC) tys) -ppr_ty env ctxt_prec ty@(ForAllTy _ _) +ppr_ty ctxt_prec ty@(ForAllTy _ _) = getPprStyle $ \ sty -> maybeParen ctxt_prec fUN_PREC $ - sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), + sep [ ptext SLIT("forall") <+> pp_tyvars sty <> ptext SLIT("."), ppr_theta theta, - ppr_ty env tOP_PREC tau + ppr_ty tOP_PREC tau ] where - (tyvars, rho) = splitForAllTys ty -- don't treat theta specially any more (KSW 1999-04) + (tyvars, rho) = splitForAllTys ty (theta, tau) = splitRhoTy rho - pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars) + pp_tyvars sty = hsep (map pprTyVarBndr some_tyvars) + where + some_tyvars | userStyle sty && not opt_PprStyle_RawTypes + = filter (not . isUTyVar) tyvars -- hide uvars from user + | otherwise + = tyvars - ppr_theta [] = empty - ppr_theta theta = parens (hsep (punctuate comma (map (ppr_pred env) theta))) - <+> ptext SLIT("=>") + ppr_theta [] = empty + ppr_theta theta = pprTheta theta <+> ptext SLIT("=>") -ppr_ty env ctxt_prec (FunTy ty1 ty2) - = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest ty2)) +ppr_ty ctxt_prec (FunTy ty1 ty2) -- we don't want to lose usage annotations or synonyms, -- so we mustn't use splitFunTys here. - where - 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 (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 + sep [ ppr_ty fUN_PREC ty1 + , ptext arrow <+> ppr_ty tOP_PREC ty2 ] - where - (uvars,sigma) = splitUsForAllTys ty - pp_uvars = hsep (map ppr uvars) + where arrow | isPredTy ty1 = SLIT("=>") + | otherwise = SLIT("->") -ppr_ty env ctxt_prec (NoteTy (UsgNote u) ty) +ppr_ty ctxt_prec (AppTy ty1 ty2) = maybeParen ctxt_prec tYCON_PREC $ - ptext SLIT("__u") <+> ppr u <+> ppr_ty env tYCON_PREC ty + ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2 -ppr_ty env ctxt_prec (PredTy p) = braces (ppr_pred env p) +ppr_ty ctxt_prec (UsageTy u ty) + = maybeParen ctxt_prec tYCON_PREC $ + ptext SLIT("__u") <+> ppr_ty tYCON_PREC u + <+> ppr_ty tYCON_PREC ty + -- fUN_PREC would be logical for u, but it yields a reduce/reduce conflict with AppTy -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] -\end{code} +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 -\begin{code} -pprTyEnv = initPprEnv b (Just ppr) b (Just (\site -> pprTyVarBndr)) b - where - b = panic "PprType:init_ppr_env" -\end{code} +ppr_ty ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty ctxt_prec ty -\begin{code} -instance Outputable UsageAnn where - ppr UsOnce = ptext SLIT("-") - ppr UsMany = ptext SLIT("!") - ppr (UsVar uv) = ppr uv +ppr_ty ctxt_prec (PredTy p) = braces (pprPred p) \end{code} @@ -244,9 +224,10 @@ We print type-variable binders with their kinds in interface files, and when in debug mode. \begin{code} +pprTyVarBndr :: TyVar -> SDoc pprTyVarBndr tyvar = getPprStyle $ \ sty -> - if (ifaceStyle sty && kind /= boxedTypeKind) || debugStyle sty then + if (ifaceStyle sty && kind /= liftedTypeKind) || debugStyle sty then hsep [ppr tyvar, dcolon, pprParendKind kind] -- See comments with ppDcolon in PprCore.lhs else @@ -279,7 +260,6 @@ getTyDescription ty TyConApp tycon _ -> getOccString tycon NoteTy (FTVNote _) ty -> getTyDescription ty NoteTy (SynNote ty1) _ -> getTyDescription ty1 - NoteTy (UsgNote _) ty -> getTyDescription ty PredTy p -> getTyDescription (predRepTy p) ForAllTy _ ty -> getTyDescription ty }