X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FPprType.lhs;h=24cbb404b63f6bdd8c78cf65c4144f886c57ffcd;hb=5e3f005d3012472e422d4ffd7dca5c21a80fca80;hp=7dfd9536e4c0aff67fdd1253970de69a645b04b3;hpb=18976e614fd90a8d81ced2c3e9cd8e38d72a1f40;p=ghc-hetmet.git diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 7dfd953..24cbb40 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -7,7 +7,7 @@ module PprType( pprKind, pprParendKind, pprType, pprParendType, - pprConstraint, pprTheta, + pprSourceType, pprPred, pprTheta, pprClassPred, pprTyVarBndr, pprTyVarBndrs, -- Junk @@ -18,30 +18,29 @@ module PprType( -- friends: -- (PprType can see all the representations it's trying to print) -import Type ( Type(..), TyNote(..), Kind, ThetaType, - splitFunTys, splitDictTy_maybe, - splitForAllTys, splitSigmaTy, splitRhoTy, - isDictTy, splitTyConApp_maybe, splitFunTy_maybe, - boxedTypeKind - ) -import Var ( TyVar, tyVarKind, - tyVarName, setTyVarName - ) -import VarEnv -import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, +import TypeRep ( Type(..), TyNote(..), IPName(..), + Kind, liftedTypeKind ) -- friend +import Type ( SourceType(..), isUTyVar, eqKind ) +import TcType ( ThetaType, PredType, ipNameName, + tcSplitSigmaTy, isPredTy, isDictTy, + tcSplitTyConApp_maybe, tcSplitFunTy_maybe + ) +import Var ( TyVar, tyVarKind ) +import Class ( Class ) +import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, tupleTyConBoxity, maybeTyConSingleCon, isEnumerationTyCon, - tyConArity, tyConUnique + tyConArity, tyConName ) -import Class ( Class ) -- others: +import CmdLineOpts ( opt_PprStyle_RawTypes ) import Maybes ( maybeToBool ) -import Name ( getOccString, NamedThing(..) ) +import Name ( getOccString, getOccName ) import Outputable -import PprEnv import Unique ( Uniquable(..) ) -import Unique -- quite a few *Keys -import Util +import Util ( lengthIs ) +import BasicTypes ( tupleParens ) +import PrelNames -- quite a few *Keys \end{code} %************************************************************************ @@ -57,23 +56,36 @@ 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 -pprConstraint :: Class -> [Type] -> SDoc -pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys) +pprPred :: PredType -> SDoc +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 <+> 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 ppr_dict theta))) - where - ppr_dict (c,tys) = pprConstraint c tys +pprTheta theta = parens (hsep (punctuate comma (map pprPred theta))) instance Outputable Type where ppr ty = pprType ty + +instance Outputable SourceType where + ppr = pprPred + +instance Outputable name => Outputable (IPName name) where + ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters + ppr (MustSplit n) = char '%' <> ppr n -- Splittable implicit parameters \end{code} @@ -95,9 +107,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 @@ -105,109 +117,99 @@ 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_uniq == typeConKey && n_tys == 1 + | tycon `hasKey` typeConKey, + [ty] <- tys = -- 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 + case ty of + TyConApp bx [] -> ppr (getOccName bx) -- Always unqualified other -> maybeParen ctxt_prec tYCON_PREC - (ppr tycon <+> tys_w_spaces) - + (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 - = parens tys_w_commas - - | isUnboxedTupleTyCon tycon - && length tys == tyConArity tycon -- no magic if partially applied - = parens (char '#' <+> tys_w_commas <+> char '#') + | isTupleTyCon tycon, + tys `lengthIs` tyConArity tycon -- No magic if partially applied + = tupleParens (tupleTyConBoxity tycon) + (sep (punctuate comma (map (ppr_ty tOP_PREC) tys))) -- LIST CASE - | 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 - | maybeToBool maybe_dict - = braces (ppr_dict env tYCON_PREC ctys) - - -- NO-ARGUMENT CASE (=> no parens) - | null tys - = ppr tycon + | tycon `hasKey` listTyConKey, + [ty] <- tys + = brackets (ppr_ty tOP_PREC ty) -- GENERAL CASE | otherwise - = maybeParen ctxt_prec tYCON_PREC (hsep [ppr tycon, tys_w_spaces]) - - where - tycon_uniq = tyConUnique tycon - n_tys = length tys - (ty1:_) = tys - Just ctys = maybe_dict - maybe_dict = splitDictTy_maybe ty -- Checks class and arity - tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys)) - tys_w_spaces = hsep (map (ppr_ty env tYCON_PREC) tys) - + = ppr_tc_app ctxt_prec tycon tys -ppr_ty env ctxt_prec ty@(ForAllTy _ _) +ppr_ty ctxt_prec ty@(ForAllTy _ _) = getPprStyle $ \ sty -> maybeParen ctxt_prec fUN_PREC $ - if ifaceStyle sty then - sep [ ptext SLIT("__forall") <+> brackets pp_tyvars, pp_ctxt, pp_body ] - else - sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), pp_maybe_ctxt, pp_body ] - where - (tyvars, rho_ty) = splitForAllTys ty - (theta, body_ty) = splitRhoTy rho_ty + sep [ ptext SLIT("forall") <+> pp_tyvars sty <> ptext SLIT("."), + ppr_theta theta, + ppr_ty tOP_PREC tau + ] + where + (tyvars, theta, tau) = tcSplitSigmaTy ty - pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars) - pp_body = ppr_ty env tOP_PREC body_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_maybe_ctxt | null theta = empty - | otherwise = pp_ctxt + ppr_theta [] = empty + ppr_theta theta = pprTheta theta <+> ptext SLIT("=>") - pp_ctxt = ppr_theta env theta <+> ptext SLIT("=>") +ppr_ty ctxt_prec (FunTy ty1 ty2) + -- we don't want to lose usage annotations or synonyms, + -- so we mustn't use splitFunTys here. + = maybeParen ctxt_prec fUN_PREC $ + sep [ ppr_ty fUN_PREC ty1 + , ptext arrow <+> ppr_ty tOP_PREC ty2 + ] + where arrow | isPredTy ty1 = SLIT("=>") + | otherwise = SLIT("->") -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)) - where - (arg_tys, result_ty) = splitFunTys ty2 - pp_rest = [ ptext SLIT("-> ") <> ppr_ty env fUN_PREC ty | ty <- arg_tys ++ [result_ty] ] +ppr_ty ctxt_prec (AppTy ty1 ty2) + = maybeParen ctxt_prec tYCON_PREC $ + ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2 -ppr_ty env ctxt_prec (AppTy ty1 ty2) +ppr_ty ctxt_prec (UsageTy u ty) = maybeParen ctxt_prec tYCON_PREC $ - ppr_ty env tOP_PREC ty1 <+> ppr_ty env tYCON_PREC ty2 + 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 env ctxt_prec (NoteTy (SynNote ty) expansion) - = ppr_ty env ctxt_prec ty +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 env ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty +ppr_ty ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty ctxt_prec ty -ppr_theta env [] = empty -ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta))) +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_dict env ctxt (clas, tys) = ppr clas <+> - hsep (map (ppr_ty env tYCON_PREC) tys) +ppr_tc_app ctxt_prec tc [] = ppr tc +ppr_tc_app ctxt_prec tc tys = maybeParen ctxt_prec tYCON_PREC + (sep [ppr tc, nest 4 (sep (map (ppr_ty tYCON_PREC) tys))]) \end{code} -\begin{code} -pprTyEnv = initPprEnv b b (Just ppr) b (Just (\site -> pprTyVarBndr)) b - where - b = panic "PprType:init_ppr_env" -\end{code} %************************************************************************ %* * @@ -219,9 +221,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 || debugStyle sty) && kind /= boxedTypeKind then + if (ifaceStyle sty && not (kind `eqKind` liftedTypeKind)) || debugStyle sty then hsep [ppr tyvar, dcolon, pprParendKind kind] -- See comments with ppDcolon in PprCore.lhs else @@ -246,19 +249,24 @@ description for profiling. getTyDescription :: Type -> String getTyDescription ty - = case (splitSigmaTy ty) of { (_, _, tau_ty) -> + = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> case tau_ty of - TyVarTy _ -> "*" - AppTy fun _ -> getTyDescription fun - FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> getOccString tycon + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + FunTy _ res -> '-' : '>' : fun_result res + TyConApp tycon _ -> getOccString tycon NoteTy (FTVNote _) ty -> getTyDescription ty NoteTy (SynNote ty1) _ -> getTyDescription ty1 - ForAllTy _ ty -> getTyDescription ty + SourceTy sty -> getSourceTyDescription sty + ForAllTy _ ty -> getTyDescription ty } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other + +getSourceTyDescription (ClassP cl tys) = getOccString cl +getSourceTyDescription (NType tc tys) = getOccString tc +getSourceTyDescription (IParam ip ty) = getOccString (ipNameName ip) \end{code} @@ -287,8 +295,8 @@ showTypeCategory ty = if isDictTy ty then '+' else - case splitTyConApp_maybe ty of - Nothing -> if maybeToBool (splitFunTy_maybe ty) + case tcSplitTyConApp_maybe ty of + Nothing -> if maybeToBool (tcSplitFunTy_maybe ty) then '>' else '.' @@ -298,13 +306,14 @@ showTypeCategory ty else if utc == intDataConKey then 'I' else if utc == floatDataConKey then 'F' else if utc == doubleDataConKey then 'D' - else if utc == integerDataConKey then 'J' + 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 isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus else if isEnumerationTyCon tycon then 'E' else if isTupleTyCon tycon then 'T' else if maybeToBool (maybeTyConSingleCon tycon) then 'S'