[commit: ghc] master: Improve pretty-printing of equalities (ad7f122)
git at git.haskell.org
git at git.haskell.org
Thu May 19 11:23:28 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/ad7f12260e227e849b815f4959df0f886ecbe807/ghc
>---------------------------------------------------------------
commit ad7f12260e227e849b815f4959df0f886ecbe807
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Mon May 16 13:42:22 2016 +0100
Improve pretty-printing of equalities
The previous pretty-printer didn't account for partially
applied equalities, causing Trac #12041
>---------------------------------------------------------------
ad7f12260e227e849b815f4959df0f886ecbe807
compiler/types/TyCoRep.hs | 107 ++++++++++-----------
.../tests/indexed-types/should_fail/T12041.hs | 12 +++
.../tests/indexed-types/should_fail/T12041.stderr | 7 ++
testsuite/tests/indexed-types/should_fail/all.T | 1 +
4 files changed, 70 insertions(+), 57 deletions(-)
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 9f79243..b1ffccb 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -2971,12 +2971,14 @@ pprTcApp_help :: (a -> Type) -> TyPrec -> (TyPrec -> a -> SDoc)
-> TyCon -> [a] -> DynFlags -> PprStyle -> SDoc
-- This one has accss to the DynFlags
pprTcApp_help to_type p pp tc tys dflags style
- | is_equality
- = print_equality
-
- | print_prefix
+ | not (isSymOcc (nameOccName tc_name)) -- Print prefix
= pprPrefixApp p pp_tc (map (pp TyConPrec) tys_wo_kinds)
+ | Just args <- mb_saturated_equality
+ = print_equality args
+
+ -- So we have an operator symbol of some kind
+
| [ty1,ty2] <- tys_wo_kinds -- Infix, two arguments;
-- we know nothing of precedence though
= pprInfixApp p pp pp_tc ty1 ty2
@@ -2986,66 +2988,57 @@ pprTcApp_help to_type p pp tc tys dflags style
|| tc_name `hasKey` unliftedTypeKindTyConKey
= pp_tc -- Do not wrap *, # in parens
- | otherwise
+ | otherwise -- Unsaturated operator
= pprPrefixApp p (parens (pp_tc)) (map (pp TyConPrec) tys_wo_kinds)
where
- tc_name = tyConName tc
+ tc_name = tyConName tc
+ pp_tc = ppr tc
+ tys_wo_kinds = suppressInvisibles to_type dflags tc tys
- is_equality = tc `hasKey` eqPrimTyConKey ||
- tc `hasKey` heqTyConKey ||
- tc `hasKey` eqReprPrimTyConKey ||
- tc `hasKey` eqTyConKey
- -- don't include Coercible here, which should be printed
- -- normally
+ mb_saturated_equality
+ | hetero_eq_tc
+ , [k1, k2, t1, t2] <- tys
+ = Just (k1, k2, t1, t2)
+ | homo_eq_tc
+ , [k, t1, t2] <- tys -- we must have (~)
+ = Just (k, k, t1, t2)
+ | otherwise
+ = Nothing
+
+ homo_eq_tc = tc `hasKey` eqTyConKey -- ~
+ hetero_eq_tc = tc `hasKey` eqPrimTyConKey -- ~#
+ || tc `hasKey` eqReprPrimTyConKey -- ~R#
+ || tc `hasKey` heqTyConKey -- ~~
-- This is all a bit ad-hoc, trying to print out the best representation
-- of equalities. If you see a better design, go for it.
- print_equality = case either_op_msg of
- Left op ->
- sep [ parens (pp TyOpPrec ty1 <+> dcolon <+> pp TyOpPrec ki1)
- , op
- , parens (pp TyOpPrec ty2 <+> dcolon <+> pp TyOpPrec ki2)]
- Right msg ->
- msg
+
+ print_equality (ki1, ki2, ty1, ty2)
+ | print_eqs
+ = ppr_infix_eq pp_tc
+
+ | hetero_eq_tc
+ , print_kinds || not (to_type ki1 `eqType` to_type ki2)
+ = ppr_infix_eq $ if tc `hasKey` eqPrimTyConKey
+ then text "~~"
+ else pp_tc
+
+ | otherwise
+ = if tc `hasKey` eqReprPrimTyConKey
+ then text "Coercible" <+> (sep [ pp TyConPrec ty1
+ , pp TyConPrec ty2 ])
+ else sep [pp TyOpPrec ty1, text "~", pp TyOpPrec ty2]
+
where
- hetero_tc = tc `hasKey` eqPrimTyConKey
- || tc `hasKey` eqReprPrimTyConKey
- || tc `hasKey` heqTyConKey
-
- print_kinds = gopt Opt_PrintExplicitKinds dflags
- print_eqs = gopt Opt_PrintEqualityRelations dflags ||
- dumpStyle style ||
- debugStyle style
-
- (ki1, ki2, ty1, ty2)
- | hetero_tc
- , [k1, k2, t1, t2] <- tys
- = (k1, k2, t1, t2)
- | [k, t1, t2] <- tys -- we must have (~)
- = (k, k, t1, t2)
- | otherwise
- = pprPanic "print_equality" pp_tc
-
- -- if "Left", print hetero equality; if "Right" just print that msg
- either_op_msg
- | print_eqs
- = Left pp_tc
-
- | hetero_tc
- , print_kinds || not (to_type ki1 `eqType` to_type ki2)
- = Left $ if tc `hasKey` eqPrimTyConKey
- then text "~~"
- else pp_tc
-
- | otherwise
- = Right $ if tc `hasKey` eqReprPrimTyConKey
- then text "Coercible" <+> (sep [ pp TyConPrec ty1
- , pp TyConPrec ty2 ])
- else sep [pp TyOpPrec ty1, text "~", pp TyOpPrec ty2]
-
- print_prefix = not (isSymOcc (nameOccName tc_name))
- tys_wo_kinds = suppressInvisibles to_type dflags tc tys
- pp_tc = ppr tc
+ ppr_infix_eq eq_op
+ = sep [ parens (pp TyOpPrec ty1 <+> dcolon <+> pp TyOpPrec ki1)
+ , eq_op
+ , parens (pp TyOpPrec ty2 <+> dcolon <+> pp TyOpPrec ki2)]
+
+ print_kinds = gopt Opt_PrintExplicitKinds dflags
+ print_eqs = gopt Opt_PrintEqualityRelations dflags ||
+ dumpStyle style ||
+ debugStyle style
------------------
-- | Given a 'TyCon',and the args to which it is applied,
diff --git a/testsuite/tests/indexed-types/should_fail/T12041.hs b/testsuite/tests/indexed-types/should_fail/T12041.hs
new file mode 100644
index 0000000..9210280
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T12041.hs
@@ -0,0 +1,12 @@
+{-# Language PolyKinds, TypeFamilies #-}
+
+module T12041 where
+
+import Data.Kind
+
+class Category (p :: i -> i -> Type) where
+ type Ob p :: i -> Constraint
+
+data I a b
+instance Category I where
+ type Ob I = (~) Int
diff --git a/testsuite/tests/indexed-types/should_fail/T12041.stderr b/testsuite/tests/indexed-types/should_fail/T12041.stderr
new file mode 100644
index 0000000..006ca37
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T12041.stderr
@@ -0,0 +1,7 @@
+
+T12041.hs:12:15: error:
+ • Expected kind ‘i -> Constraint’,
+ but ‘(~) Int’ has kind ‘* -> Constraint’
+ • In the type ‘(~) Int’
+ In the type instance declaration for ‘Ob’
+ In the instance declaration for ‘Category I’
diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T
index dfc0326..041282e 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -140,3 +140,4 @@ test('T10899', normal, compile_fail, [''])
test('T11136', normal, compile_fail, [''])
test('T7788', normal, compile_fail, [''])
test('T11450', normal, compile_fail, [''])
+test('T12041', normal, compile_fail, [''])
More information about the ghc-commits
mailing list