diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/BasicTypes.hs | 57 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.hs | 4 | ||||
| -rw-r--r-- | compiler/iface/IfaceType.hs | 87 | ||||
| -rw-r--r-- | compiler/typecheck/TcErrors.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcType.hs | 2 | ||||
| -rw-r--r-- | compiler/types/TyCoRep.hs | 32 | ||||
| -rw-r--r-- | compiler/types/Type.hs | 3 |
7 files changed, 124 insertions, 63 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index b67e6628ee..90a043de76 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -700,13 +700,68 @@ data TyPrec -- See Note [Precedence in types] in TyCoRep.hs | FunPrec -- Function args; no parens for tycon apps | TyOpPrec -- Infix operator | TyConPrec -- Tycon args; no parens for atomic - deriving( Eq, Ord ) + +instance Eq TyPrec where + (==) a b = case compare a b of + EQ -> True + _ -> False + +instance Ord TyPrec where + compare TopPrec TopPrec = EQ + compare TopPrec _ = LT + + compare FunPrec TopPrec = GT + compare FunPrec FunPrec = EQ + compare FunPrec TyOpPrec = EQ -- See Note [Type operator precedence] + compare FunPrec TyConPrec = LT + + compare TyOpPrec TopPrec = GT + compare TyOpPrec FunPrec = EQ -- See Note [Type operator precedence] + compare TyOpPrec TyOpPrec = EQ + compare TyOpPrec TyConPrec = LT + + compare TyConPrec TyConPrec = EQ + compare TyConPrec _ = GT maybeParen :: TyPrec -> TyPrec -> SDoc -> SDoc maybeParen ctxt_prec inner_prec pretty | ctxt_prec < inner_prec = pretty | otherwise = parens pretty +{- Note [Precedence in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many pretty-printing functions have type + ppr_ty :: TyPrec -> Type -> SDoc + +The TyPrec gives the binding strength of the context. For example, in + T ty1 ty2 +we will pretty-print 'ty1' and 'ty2' with the call + (ppr_ty TyConPrec ty) +to indicate that the context is that of an argument of a TyConApp. + +We use this consistently for Type and HsType. + +Note [Type operator precedence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't keep the fixity of type operators in the operator. So the +pretty printer follows the following precedence order: + + TyConPrec Type constructor application + TyOpPrec/FunPrec Operator application and function arrow + +We have FunPrec and TyOpPrec to represent the precedence of function +arrow and type operators respectively, but currently we implement +FunPred == TyOpPrec, so that we don't distinguish the two. Reason: +it's hard to parse a type like + a ~ b => c * d -> e - f + +By treating TyOpPrec = FunPrec we end up with more parens + (a ~ b) => (c * d) -> (e - f) + +But the two are different constructors of TyPrec so we could make +(->) bind more or less tightly if we wanted. +-} + {- ************************************************************************ * * diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 8ea6b0b3a0..2144a28597 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -1286,7 +1286,7 @@ ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty TopPrec ty) ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty) ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty) ppr_mono_ty _ (HsSpliceTy s _) = pprSplice s -ppr_mono_ty _ (HsCoreTy ty) = ppr ty +ppr_mono_ty prec (HsCoreTy ty) = pprPrecType prec ty ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) = quote $ brackets (interpp'SP tys) ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) @@ -1300,7 +1300,7 @@ ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2 ppr_mono_ty _ctxt_prec (HsAppsTy tys) - = hsep (map (ppr_app_ty TopPrec . unLoc) tys) + = hsep (map (ppr_app_ty TyConPrec . unLoc) tys) ppr_mono_ty _ctxt_prec (HsAppTy fun_ty arg_ty) = hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty] diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 95d6369d45..39e30283db 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -30,7 +30,7 @@ module IfaceType ( tcArgsIfaceTypes, -- Printing - pprIfaceType, pprParendIfaceType, + pprIfaceType, pprParendIfaceType, pprPrecIfaceType, pprIfaceContext, pprIfaceContextArr, pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs, @@ -227,6 +227,7 @@ Namely we handle these cases, eqPrimTyCon ~# ~~ eqReprPrimTyCon Coercible Coercible +See Note [The equality types story] in TysPrim. -} data IfaceTyConInfo -- Used to guide pretty-printing @@ -492,15 +493,15 @@ if_print_coercions yes no then yes else no -pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc -pprIfaceInfixApp pp p pp_tc ty1 ty2 - = maybeParen p FunPrec $ - sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2] +pprIfaceInfixApp :: TyPrec -> SDoc -> SDoc -> SDoc -> SDoc +pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2 + = maybeParen ctxt_prec TyOpPrec $ + sep [pp_ty1, pp_tc <+> pp_ty2] pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc -pprIfacePrefixApp p pp_fun pp_tys +pprIfacePrefixApp ctxt_prec pp_fun pp_tys | null pp_tys = pp_fun - | otherwise = maybeParen p TyConPrec $ + | otherwise = maybeParen ctxt_prec TyConPrec $ hang pp_fun 2 (sep pp_tys) -- ----------------------------- Printing binders ------------------------------------ @@ -565,8 +566,11 @@ instance Outputable IfaceType where ppr ty = pprIfaceType ty pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc -pprIfaceType = eliminateRuntimeRep (ppr_ty TopPrec) -pprParendIfaceType = eliminateRuntimeRep (ppr_ty TyConPrec) +pprIfaceType = pprPrecIfaceType TopPrec +pprParendIfaceType = pprPrecIfaceType TyConPrec + +pprPrecIfaceType :: TyPrec -> IfaceType -> SDoc +pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty ppr_ty :: TyPrec -> IfaceType -> SDoc ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reson for IfaceFreeTyVar! @@ -880,8 +884,8 @@ pprTyTcApp' ctxt_prec tc tys dflags style -- Suppress detail unles you _really_ want to see -> text "(TypeError ...)" - | Just doc <- ppr_equality tc (tcArgsIfaceTypes tys) - -> maybeParen ctxt_prec TyConPrec doc + | Just doc <- ppr_equality ctxt_prec tc (tcArgsIfaceTypes tys) + -> doc | otherwise -> ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds @@ -891,9 +895,10 @@ pprTyTcApp' ctxt_prec tc tys dflags style -- | Pretty-print a type-level equality. -- --- See Note [Equality predicates in IfaceType]. -ppr_equality :: IfaceTyCon -> [IfaceType] -> Maybe SDoc -ppr_equality tc args +-- See Note [Equality predicates in IfaceType] +-- and Note [The equality types story] in TysPrim +ppr_equality :: TyPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc +ppr_equality ctxt_prec tc args | hetero_eq_tc , [k1, k2, t1, t2] <- args = Just $ print_equality (k1, k2, t1, t2) @@ -914,11 +919,10 @@ ppr_equality tc args hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#) || tc_name `hasKey` eqReprPrimTyConKey -- (~R#) || tc_name `hasKey` heqTyConKey -- (~~) - print_equality args = - sdocWithDynFlags - $ \dflags -> getPprStyle - $ \style -> print_equality' args style dflags + sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + print_equality' args style dflags print_equality' (ki1, ki2, ty1, ty2) style dflags | print_eqs @@ -930,14 +934,15 @@ ppr_equality tc args | otherwise = if tc_name `hasKey` eqReprPrimTyConKey - then text "Coercible" - <+> sep [ pp TyConPrec ty1, pp TyConPrec ty2 ] - else sep [pp TyOpPrec ty1, char '~', pp TyOpPrec ty2] + then pprIfacePrefixApp ctxt_prec (text "Coercible") + [pp TyConPrec ty1, pp TyConPrec ty2] + else pprIfaceInfixApp ctxt_prec (char '~') + (pp TyOpPrec ty1) (pp TyOpPrec ty2) where ppr_infix_eq eq_op - = sep [ parens (pp TyOpPrec ty1 <+> dcolon <+> pp TyOpPrec ki1) - , eq_op - , parens (pp TyOpPrec ty2 <+> dcolon <+> pp TyOpPrec ki2) ] + = pprIfaceInfixApp ctxt_prec eq_op + (parens (pp TopPrec ty1 <+> dcolon <+> pp TyOpPrec ki1)) + (parens (pp TopPrec ty2 <+> dcolon <+> pp TyOpPrec ki2)) print_kinds = gopt Opt_PrintExplicitKinds dflags print_eqs = gopt Opt_PrintEqualityRelations dflags || @@ -963,7 +968,8 @@ ppr_iface_tc_app pp ctxt_prec tc tys | [ty1,ty2] <- tys -- Infix, two arguments; -- we know nothing of precedence though - = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2 + = pprIfaceInfixApp ctxt_prec (ppr tc) + (pp TyOpPrec ty1) (pp TyOpPrec ty2) | otherwise = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys) @@ -1024,7 +1030,8 @@ ppr_co ctxt_prec (IfaceAppCo co1 co2) = maybeParen ctxt_prec TyConPrec $ ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2 ppr_co ctxt_prec co@(IfaceForAllCo {}) - = maybeParen ctxt_prec FunPrec (pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)) + = maybeParen ctxt_prec FunPrec $ + pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) where (tvs, inner_co) = split_co co @@ -1208,20 +1215,24 @@ instance Binary IfaceTcArgs where --- | Prints "(C a, D b) =>", including the arrow. This is used when we want to --- print a context in a type. +-- | Prints "(C a, D b) =>", including the arrow. +-- Used when we want to print a context in a type, so we +-- use FunPrec to decide whether to parenthesise a singleton +-- predicate; e.g. Num a => a -> a pprIfaceContextArr :: [IfacePredType] -> SDoc pprIfaceContextArr [] = empty -pprIfaceContextArr [pred] = ppr_ty TyOpPrec pred <+> darrow -pprIfaceContextArr preds = - parens (fsep (punctuate comma (map ppr preds))) <+> darrow - --- | Prints a context or @()@ if empty. This is used when, e.g., we want to --- display a context in an error message. -pprIfaceContext :: [IfacePredType] -> SDoc -pprIfaceContext [] = parens empty -pprIfaceContext [pred] = ppr_ty TyOpPrec pred -pprIfaceContext preds = parens (fsep (punctuate comma (map ppr preds))) +pprIfaceContextArr [pred] = ppr_ty FunPrec pred <+> darrow +pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow + +-- | Prints a context or @()@ if empty +-- You give it the context precedence +pprIfaceContext :: TyPrec -> [IfacePredType] -> SDoc +pprIfaceContext _ [] = text "()" +pprIfaceContext prec [pred] = ppr_ty prec pred +pprIfaceContext _ preds = ppr_parend_preds preds + +ppr_parend_preds :: [IfacePredType] -> SDoc +ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) instance Binary IfaceType where put_ _ (IfaceFreeTyVar tv) diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index c9e07fc43d..6d422a4c44 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -1236,7 +1236,7 @@ mkIPErr ctxt cts msg | null givens = addArising orig $ sep [ text "Unbound implicit parameter" <> plural cts - , nest 2 (pprTheta preds) ] + , nest 2 (pprParendTheta preds) ] | otherwise = couldNotDeduce givens (preds, orig) diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index e22dfc3822..e12b70b6d1 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -183,7 +183,7 @@ module TcType ( pprKind, pprParendKind, pprSigmaType, pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory, - pprTheta, pprThetaArrowTy, pprClassPred, + pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, pprTvBndr, pprTvBndrs, TypeSize, sizeType, sizeTypes, toposortTyVars diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 300ef80a8f..74ebfbeb9a 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -55,9 +55,10 @@ module TyCoRep ( pickLR, -- * Pretty-printing - pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, + pprType, pprParendType, pprPrecType, + pprTypeApp, pprTvBndr, pprTvBndrs, pprSigmaType, - pprTheta, pprForAll, pprUserForAll, + pprTheta, pprParendTheta, pprForAll, pprUserForAll, pprTyVar, pprTyVars, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, @@ -2424,27 +2425,17 @@ 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. -Note [Precedence in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't keep the fixity of type operators in the operator. So the pretty printer -follows the following precedence order: - Type constructor application binds more tightly than - Operator applications which bind more tightly than - Function arrow - -So we might see a :+: T b -> c -meaning (a :+: (T b)) -> c - -Maybe operator applications should bind a bit less tightly? - -Anyway, that's the current story; it is used consistently for Type and HsType. +See Note [Precedence in types] in BasicTypes. -} ------------------ pprType, pprParendType :: Type -> SDoc -pprType = pprIfaceType . tidyToIfaceType -pprParendType = pprParendIfaceType . tidyToIfaceType +pprType = pprPrecType TopPrec +pprParendType = pprPrecType TyConPrec + +pprPrecType :: TyPrec -> Type -> SDoc +pprPrecType prec ty = pprPrecIfaceType prec (tidyToIfaceType ty) pprTyLit :: TyLit -> SDoc pprTyLit = pprIfaceTyLit . toIfaceTyLit @@ -2471,7 +2462,10 @@ pprClassPred clas tys = pprTypeApp (classTyCon clas) tys ------------ pprTheta :: ThetaType -> SDoc -pprTheta = pprIfaceContext . map tidyToIfaceType +pprTheta = pprIfaceContext TopPrec . map tidyToIfaceType + +pprParendTheta :: ThetaType -> SDoc +pprParendTheta = pprIfaceContext TyConPrec . map tidyToIfaceType pprThetaArrowTy :: ThetaType -> SDoc pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 7750a35072..65c02ba719 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -182,7 +182,8 @@ module Type ( cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, -- * Pretty-printing - pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprShortTyThing, + pprType, pprParendType, pprPrecType, + pprTypeApp, pprTyThingCategory, pprShortTyThing, pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType, ppSuggestExplicitKinds, pprTheta, pprThetaArrowTy, pprClassPred, |