X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FPprType.lhs;h=4a04bffb5528f5923dabfa47ed0fc0edf17d7071;hb=abbc5a0be1df84a33015470319062ed7a3aa3153;hp=6c663034c088d676e1f4dfae5daf7cc8f905bf22;hpb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;p=ghc-hetmet.git diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 6c66303..4a04bff 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -7,7 +7,7 @@ module PprType( pprKind, pprParendKind, pprType, pprParendType, - pprPred, pprTheta, pprClassPred, + pprSourceType, pprPred, pprTheta, pprClassPred, pprTyVarBndr, pprTyVarBndrs, -- Junk @@ -18,26 +18,26 @@ module PprType( -- friends: -- (PprType can see all the representations it's trying to print) -import TypeRep ( Type(..), TyNote(..), Kind, liftedTypeKind ) -- friend -import Type ( SourceType(..), isUTyVar, eqKind ) -import TcType ( ThetaType, PredType, tcSplitPredTy_maybe, +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, tyConName + maybeTyConSingleCon, isEnumerationTyCon, tyConArity ) -- others: -import CmdLineOpts ( opt_PprStyle_RawTypes ) import Maybes ( maybeToBool ) import Name ( getOccString, getOccName ) +import OccName ( occNameUserString ) import Outputable import Unique ( Uniquable(..) ) -import BasicTypes ( tupleParens ) +import Util ( lengthIs ) +import BasicTypes ( IPName(..), tupleParens, ipNameName ) import PrelNames -- quite a few *Keys \end{code} @@ -62,21 +62,37 @@ pprKind = pprType pprParendKind = pprParendType pprPred :: PredType -> SDoc -pprPred (ClassP clas tys) = pprClassPred clas tys -pprPred (IParam n ty) = hsep [ptext SLIT("?") <> ppr n, - ptext SLIT("::"), ppr ty] +pprPred = pprSourceType + +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) pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = ppr clas <+> hsep (map pprParendType tys) +pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys) pprTheta :: ThetaType -> SDoc -pprTheta theta = parens (hsep (punctuate comma (map pprPred theta))) +pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) instance Outputable Type where ppr ty = pprType ty -instance Outputable PredType where +instance Outputable SourceType where ppr = pprPred + +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 + +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} @@ -124,15 +140,9 @@ ppr_ty ctxt_prec ty@(TyConApp tycon tys) other -> maybeParen ctxt_prec tYCON_PREC (ppr tycon <+> ppr_ty tYCON_PREC ty) - -- USAGE CASE - | (tycon `hasKey` usOnceTyConKey || tycon `hasKey` usManyTyConKey), - null tys - = -- 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 + tys `lengthIs` tyConArity tycon -- No magic if partially applied = tupleParens (tupleTyConBoxity tycon) (sep (punctuate comma (map (ppr_ty tOP_PREC) tys))) @@ -141,10 +151,18 @@ ppr_ty ctxt_prec ty@(TyConApp tycon tys) [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_tc_app ctxt_prec tycon tys + where + pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") + ppr_ty ctxt_prec ty@(ForAllTy _ _) = getPprStyle $ \ sty -> @@ -155,13 +173,7 @@ ppr_ty ctxt_prec ty@(ForAllTy _ _) ] where (tyvars, theta, tau) = tcSplitSigmaTy ty - - pp_tyvars sty = sep (map pprTyVarBndr some_tyvars) - where - some_tyvars | userStyle sty && not opt_PprStyle_RawTypes - = filter (not . isUTyVar) tyvars -- hide uvars from user - | otherwise - = tyvars + pp_tyvars sty = sep (map pprTyVarBndr tyvars) ppr_theta [] = empty ppr_theta theta = pprTheta theta <+> ptext SLIT("=>") @@ -181,22 +193,14 @@ 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 (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_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_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 @@ -217,7 +221,7 @@ and when in debug mode. pprTyVarBndr :: TyVar -> SDoc pprTyVarBndr tyvar = getPprStyle $ \ sty -> - if (ifaceStyle sty && not (kind `eqKind` liftedTypeKind)) || debugStyle sty then + if debugStyle sty then hsep [ppr tyvar, dcolon, pprParendKind kind] -- See comments with ppDcolon in PprCore.lhs else @@ -247,7 +251,7 @@ getTyDescription ty TyVarTy _ -> "*" AppTy fun _ -> getTyDescription fun FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> getOccString tycon + TyConApp tycon _ -> occNameUserString (getOccName tycon) NoteTy (FTVNote _) ty -> getTyDescription ty NoteTy (SynNote ty1) _ -> getTyDescription ty1 SourceTy sty -> getSourceTyDescription sty @@ -259,7 +263,7 @@ getTyDescription ty getSourceTyDescription (ClassP cl tys) = getOccString cl getSourceTyDescription (NType tc tys) = getOccString tc -getSourceTyDescription (IParam id ty) = getOccString id +getSourceTyDescription (IParam ip ty) = getOccString (ipNameName ip) \end{code}