[commit: ghc] ghc-8.0: Improve pretty-printing of equalities (e9f2900)

git at git.haskell.org git at git.haskell.org
Wed Aug 24 00:22:40 UTC 2016


Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/e9f29008ed5ab4d368138f04338e93dee2713257/ghc

>---------------------------------------------------------------

commit e9f29008ed5ab4d368138f04338e93dee2713257
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
    
    (cherry picked from commit ad7f12260e227e849b815f4959df0f886ecbe807)


>---------------------------------------------------------------

e9f29008ed5ab4d368138f04338e93dee2713257
 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 470b240..c6b8abf 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -2881,12 +2881,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
@@ -2896,66 +2898,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 c6f29a4..83dd708 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -139,3 +139,4 @@ test('T10817', normal, compile_fail, [''])
 test('T10899', normal, compile_fail, [''])
 test('T11136', normal, compile_fail, [''])
 test('T7788', normal, compile_fail, [''])
+test('T12041', normal, compile_fail, [''])



More information about the ghc-commits mailing list