Commit b15724ad authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Print infix type constructors in an infix way

Fixes Trac #1425.  The printer for types doesn't know about fixities.
(It could be educated to know, but it doesn't at the moment.)  So it
treats all infix tycons as of precedence less than application and function
arrrow.

I took a slight shortcut and reused function-arrow prededence, so I think
you may get
	T -> T :% T
meaning
	T -> (T :% T)

If that becomes a problem we can fix it.
parent 75ebc06a
......@@ -69,7 +69,7 @@ pprTyThingHdr exts (AClass cls) = pprClassHdr exts cls
pprTyConHdr exts tyCon
| Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
= ptext keyword <+> ptext SLIT("instance") <+> pprTypeApp (ppr_bndr tyCon) tys
= ptext keyword <+> ptext SLIT("instance") <+> pprTypeApp tyCon (ppr_bndr tyCon) tys
| otherwise
= ptext keyword <+> opt_family <+> ppr_bndr tyCon <+> hsep (map ppr vars)
where
......
......@@ -707,7 +707,7 @@ wrongThingErr expected thing name
ptext SLIT("used as a") <+> text expected)
famInstNotFound tycon tys what
= failWithTc (msg <+> quotes (pprTypeApp (ppr tycon) tys))
= failWithTc (msg <+> quotes (pprTypeApp tycon (ppr tycon) tys))
where
msg = ptext $ if length what > 1
then SLIT("More than one family instance for")
......
......@@ -95,7 +95,7 @@ pprFamInstHdr :: FamInst -> SDoc
pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
= pprTyConSort <+> pprHead
where
pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys
pprHead = pprTypeApp fam (ppr fam) tys
pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
| isNewTyCon tycon = ptext SLIT("newtype instance")
| isSynTyCon tycon = ptext SLIT("type instance")
......
......@@ -433,17 +433,19 @@ pprType, pprParendType :: Type -> SDoc
pprType ty = ppr_type TopPrec ty
pprParendType ty = ppr_type TyConPrec ty
pprTypeApp :: SDoc -> [Type] -> SDoc
pprTypeApp pp tys = hang pp 2 (sep (map pprParendType tys))
pprTypeApp :: NamedThing a => a -> SDoc -> [Type] -> SDoc
-- The first arg is the tycon; it's used to arrange printing infix
-- if it looks like an operator
-- Second arg is the pretty-printed tycon
pprTypeApp tc pp_tc tys = ppr_type_app TopPrec (getName tc) pp_tc tys
------------------
pprPred :: PredType -> SDoc
pprPred (ClassP cls tys) = pprClassPred cls tys
pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty
pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext SLIT("~")), ppr ty2]
pprClassPred :: Class -> [Type] -> SDoc
pprClassPred clas tys = pprTypeApp (parenSymOcc (getOccName clas) (ppr clas)) tys
pprClassPred clas tys = ppr_type_app TopPrec (getName clas) (ppr clas) tys
pprTheta :: ThetaType -> SDoc
pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
......@@ -523,10 +525,27 @@ ppr_tc_app p tc tys
| isTupleTyCon tc && tyConArity tc == length tys
= tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
| otherwise
= maybeParen p TyConPrec (pprTypeApp (ppr_tc tc) tys)
= ppr_type_app p (getName tc) (ppr_naked_tc tc) tys
ppr_type_app :: Prec -> Name -> SDoc -> [Type] -> SDoc
ppr_type_app p tc pp_tc tys
| is_sym_occ -- Print infix if possible
, [ty1,ty2] <- tys -- We know nothing of precedence though
= maybeParen p FunPrec (sep [ppr_type FunPrec ty1,
pp_tc <+> ppr_type FunPrec ty2])
| otherwise
= maybeParen p TyConPrec (hang paren_tc 2 (sep (map pprParendType tys)))
where
is_sym_occ = isSymOcc (getOccName tc)
paren_tc | is_sym_occ = parens pp_tc
| otherwise = pp_tc
ppr_tc :: TyCon -> SDoc
ppr_tc tc = parenSymOcc (getOccName tc) (pp_nt_debug <> ppr tc)
ppr_tc tc = parenSymOcc (getOccName tc) (ppr_naked_tc tc)
ppr_naked_tc :: TyCon -> SDoc -- No brackets for SymOcc
ppr_naked_tc tc
= pp_nt_debug <> ppr tc
where
pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
then ptext SLIT("<recnt>")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment