print * in unicode correctly (fixes #12550)

Test Plan: validate

Reviewers: simonpj, austin, bgamari, goldfire

Reviewed By: bgamari, goldfire

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2829

8 files changed, 88 insertions, 36 deletions

diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index 20533a8516..7e1f2c7b70 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -692,7 +692,7 @@ pprSafeOverlap False = empty
 ************************************************************************
 -}
 
-data TyPrec   -- See Note [Prededence in types]
+data TyPrec   -- See Note [Precedence in types] in TyCoRep.hs
   = TopPrec         -- No parens
   | FunPrec         -- Function args; no parens for tycon apps
   | TyOpPrec        -- Infix operator
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index dbca426cbe..b667522007 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -188,7 +188,7 @@ data IfaceTyConSort = IfaceNormalTyCon          -- ^ a regular tycon
 
 {- Note [TcTyVars in IfaceType]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Nowadays (since Nov 16) we pretty-print a Type by converting to an
+Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to an
 IfaceType and pretty printing that.  This eliminates a lot of
 pretty-print duplication, and it matches what we do with
 pretty-printing TyThings.
@@ -966,7 +966,7 @@ pprTyTcApp' ctxt_prec tc tys dflags style
   | tc `ifaceTyConHasKey` tYPETyConKey
   , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys
   , rep `ifaceTyConHasKey` ptrRepLiftedDataConKey
-  = unicodeSyntax (char '★') (char '*')
+  = kindStar
 
   | tc `ifaceTyConHasKey` tYPETyConKey
   , ITC_Vis (IfaceTyConApp rep ITC_Nil) ITC_Nil <- tys
@@ -1050,22 +1050,23 @@ ppr_iface_tc_app pp _ tc [ty]
   | tc `ifaceTyConHasKey` parrTyConKey = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
 
 ppr_iface_tc_app pp ctxt_prec tc tys
-  | not (isSymOcc (nameOccName tc_name))
+  |  tc `ifaceTyConHasKey` starKindTyConKey
+  || tc `ifaceTyConHasKey` liftedTypeKindTyConKey
+  || tc `ifaceTyConHasKey` unicodeStarKindTyConKey
+  = kindStar   -- Handle unicode; do not wrap * in parens
+
+  | tc `ifaceTyConHasKey` unliftedTypeKindTyConKey
+  = ppr tc  -- Do not wrap # in parens
+
+  | not (isSymOcc (nameOccName (ifaceTyConName tc)))
   = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)
 
   | [ty1,ty2] <- tys  -- Infix, two arguments;
                       -- we know nothing of precedence though
   = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2
 
-  |  tc `ifaceTyConHasKey` starKindTyConKey
-  || tc `ifaceTyConHasKey` unliftedTypeKindTyConKey
-  || tc `ifaceTyConHasKey` unicodeStarKindTyConKey
-  = ppr tc   -- Do not wrap *, # in parens
-
   | otherwise
   = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys)
-  where
-    tc_name = ifaceTyConName tc
 
 pprSum :: Arity -> IsPromoted -> IfaceTcArgs -> SDoc
 pprSum _arity is_promoted args
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 6680ca816b..c007321988 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -2368,7 +2368,7 @@ 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
-operates the following precedene structre:
+follows the following precedence order:
    Type constructor application   binds more tightly than
    Operator applications          which bind more tightly than
    Function arrow
@@ -2378,7 +2378,7 @@ meaning          (a :+: (T b)) -> c
 
 Maybe operator applications should bind a bit less tightly?
 
-Anyway, that's the current story, and it is used consistently for Type and HsType
+Anyway, that's the current story; it is used consistently for Type and HsType.
 -}
 
 ------------------
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 32d1b5dac9..371856f5ea 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -29,7 +29,7 @@ module Outputable (
         semi, comma, colon, dcolon, space, equals, dot, vbar,
         arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
-        blankLine, forAllLit,
+        blankLine, forAllLit, kindStar,
         (<>), (<+>), hcat, hsep,
         ($$), ($+$), vcat,
         sep, cat,
@@ -590,6 +590,9 @@ rbrace     = docToSDoc $ Pretty.rbrace
 forAllLit :: SDoc
 forAllLit = unicodeSyntax (char '∀') (text "forall")
 
+kindStar :: SDoc
+kindStar = unicodeSyntax (char '★') (char '*')
+
 unicodeSyntax :: SDoc -> SDoc -> SDoc
 unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
     if useUnicode dflags && useUnicodeSyntax dflags
diff --git a/testsuite/tests/generics/T10604/T10604_deriving.stderr b/testsuite/tests/generics/T10604/T10604_deriving.stderr
index d90c2733b1..6898af06a8 100644
--- a/testsuite/tests/generics/T10604/T10604_deriving.stderr
+++ b/testsuite/tests/generics/T10604/T10604_deriving.stderr
@@ -56,7 +56,7 @@ Derived class instances:
             -> T10604_deriving.Wrap g1 }
   
   instance GHC.Generics.Generic1
-             (GHC.Types.* -> GHC.Types.*) T10604_deriving.Wrap where
+             (* -> *) T10604_deriving.Wrap where
     GHC.Generics.from1 x
       = GHC.Generics.M1
           (case x of {
@@ -67,7 +67,7 @@ Derived class instances:
           (GHC.Generics.M1 (GHC.Generics.M1 g1))
             -> T10604_deriving.Wrap (GHC.Generics.unRec1 g1) }
   
-  instance forall k (a :: k -> GHC.Types.*).
+  instance forall k (a :: k -> *).
            GHC.Generics.Generic (T10604_deriving.Wrap2 k a) where
     GHC.Generics.from x
       = GHC.Generics.M1
@@ -80,7 +80,7 @@ Derived class instances:
             -> T10604_deriving.Wrap2 g1 }
   
   instance GHC.Generics.Generic1
-             (k -> GHC.Types.*) (T10604_deriving.Wrap2 k) where
+             (k -> *) (T10604_deriving.Wrap2 k) where
     GHC.Generics.from1 x
       = GHC.Generics.M1
           (case x of {
@@ -250,23 +250,23 @@ Derived type family instances:
                                                            (GHC.Generics.Rec0
                                                               *
                                                               (T10604_deriving.Proxy
-                                                                 (GHC.Types.* -> GHC.Types.*) a))))
+                                                                 (* -> *) a))))
   type GHC.Generics.Rep1
-         (GHC.Types.* -> GHC.Types.*) T10604_deriving.Wrap = GHC.Generics.D1
-                                                               (GHC.Types.* -> GHC.Types.*)
+         (* -> *) T10604_deriving.Wrap = GHC.Generics.D1
+                                                               (* -> *)
                                                                ('GHC.Generics.MetaData
                                                                   "Wrap"
                                                                   "T10604_deriving"
                                                                   "main"
                                                                   'GHC.Types.False)
                                                                (GHC.Generics.C1
-                                                                  (GHC.Types.* -> GHC.Types.*)
+                                                                  (* -> *)
                                                                   ('GHC.Generics.MetaCons
                                                                      "Wrap"
                                                                      'GHC.Generics.PrefixI
                                                                      'GHC.Types.False)
                                                                   (GHC.Generics.S1
-                                                                     (GHC.Types.* -> GHC.Types.*)
+                                                                     (* -> *)
                                                                      ('GHC.Generics.MetaSel
                                                                         ('GHC.Base.Nothing
                                                                            GHC.Types.Symbol)
@@ -274,10 +274,10 @@ Derived type family instances:
                                                                         'GHC.Generics.NoSourceStrictness
                                                                         'GHC.Generics.DecidedLazy)
                                                                      (GHC.Generics.Rec1
-                                                                        (GHC.Types.* -> GHC.Types.*)
+                                                                        (* -> *)
                                                                         (T10604_deriving.Proxy
-                                                                           (GHC.Types.*
-                                                                            -> GHC.Types.*)))))
+                                                                           (*
+                                                                            -> *)))))
   type GHC.Generics.Rep (T10604_deriving.Wrap2 k a) = GHC.Generics.D1
                                                         *
                                                         ('GHC.Generics.MetaData
@@ -304,23 +304,23 @@ Derived type family instances:
                                                                  (T10604_deriving.Proxy
                                                                     *
                                                                     (T10604_deriving.Proxy
-                                                                       (k -> GHC.Types.*) a)))))
+                                                                       (k -> *) a)))))
   type GHC.Generics.Rep1
-         (k -> GHC.Types.*) (T10604_deriving.Wrap2 k) = GHC.Generics.D1
-                                                          (k -> GHC.Types.*)
+         (k -> *) (T10604_deriving.Wrap2 k) = GHC.Generics.D1
+                                                          (k -> *)
                                                           ('GHC.Generics.MetaData
                                                              "Wrap2"
                                                              "T10604_deriving"
                                                              "main"
                                                              'GHC.Types.False)
                                                           (GHC.Generics.C1
-                                                             (k -> GHC.Types.*)
+                                                             (k -> *)
                                                              ('GHC.Generics.MetaCons
                                                                 "Wrap2"
                                                                 'GHC.Generics.PrefixI
                                                                 'GHC.Types.False)
                                                              (GHC.Generics.S1
-                                                                (k -> GHC.Types.*)
+                                                                (k -> *)
                                                                 ('GHC.Generics.MetaSel
                                                                    ('GHC.Base.Nothing
                                                                       GHC.Types.Symbol)
@@ -329,12 +329,12 @@ Derived type family instances:
                                                                    'GHC.Generics.DecidedLazy)
                                                                 ((GHC.Generics.:.:)
                                                                    *
-                                                                   (k -> GHC.Types.*)
+                                                                   (k -> *)
                                                                    (T10604_deriving.Proxy *)
                                                                    (GHC.Generics.Rec1
-                                                                      (k -> GHC.Types.*)
+                                                                      (k -> *)
                                                                       (T10604_deriving.Proxy
-                                                                         (k -> GHC.Types.*))))))
+                                                                         (k -> *))))))
   type GHC.Generics.Rep
          (T10604_deriving.SumOfProducts k a) = GHC.Generics.D1
                                                  *
diff --git a/testsuite/tests/ghci/scripts/T12550.script b/testsuite/tests/ghci/scripts/T12550.script
index 3964035e8b..dad2a47e65 100644
--- a/testsuite/tests/ghci/scripts/T12550.script
+++ b/testsuite/tests/ghci/scripts/T12550.script
@@ -1,10 +1,44 @@
-:set -fprint-unicode-syntax -fprint-explicit-foralls
+:set -fprint-explicit-foralls -XKindSignatures -XExplicitNamespaces
+import Data.Kind (type Type)
+
+
+class C a where f :: a b
+:t f
+class C (a :: * -> * ) where f :: a b
+:t f
+class C (a :: ★ -> * ) where f :: a b
+:t f
+class C (a :: * -> ★ ) where f :: a b
+:t f
+class C (a :: ★ -> ★ ) where f :: a b
+:t f
+class C (a :: Type -> Type ) where f :: a b
+:t f
+
+:set -fprint-unicode-syntax 
+
+class C a where f :: a b
+:t f
+class C (a :: * -> * ) where f :: a b
+:t f
+class C (a :: ★ -> * ) where f :: a b
+:t f
+class C (a :: * -> ★ ) where f :: a b
+:t f
+class C (a :: ★ -> ★ ) where f :: a b
+:t f
+class C (a :: Type -> Type ) where f :: a b
+:t f
 
 :t fmap
 :i fmap
 :k Functor
-:m + GHC.Generics
+
+import GHC.Generics
 :i Functor
 :t datatypeName
 :i datatypeName
 :t (:*:)
+:k Rep
+:k M1
+
diff --git a/testsuite/tests/ghci/scripts/T12550.stdout b/testsuite/tests/ghci/scripts/T12550.stdout
index 442bc05c71..de3f8d15d6 100644
--- a/testsuite/tests/ghci/scripts/T12550.stdout
+++ b/testsuite/tests/ghci/scripts/T12550.stdout
@@ -1,3 +1,15 @@
+f :: forall {b} {a :: * -> *}. C a => a b
+f :: forall {b} {a :: * -> *}. C a => a b
+f :: forall {b} {a :: * -> *}. C a => a b
+f :: forall {b} {a :: * -> *}. C a => a b
+f :: forall {b} {a :: * -> *}. C a => a b
+f :: forall {b} {a :: * -> *}. C a => a b
+f ∷ ∀ {b} {a ∷ ★ → ★}. C a ⇒ a b
+f ∷ ∀ {b} {a ∷ ★ → ★}. C a ⇒ a b
+f ∷ ∀ {b} {a ∷ ★ → ★}. C a ⇒ a b
+f ∷ ∀ {b} {a ∷ ★ → ★}. C a ⇒ a b
+f ∷ ∀ {b} {a ∷ ★ → ★}. C a ⇒ a b
+f ∷ ∀ {b} {a ∷ ★ → ★}. C a ⇒ a b
 fmap ∷ ∀ {f ∷ ★ → ★} {b} {a}. Functor f ⇒ (a → b) → f a → f b
 class Functor (f ∷ ★ → ★) where
   fmap ∷ ∀ a b. (a → b) → f a → f b
@@ -51,3 +63,5 @@ class Datatype (d ∷ k) where
   ...
   	-- Defined in ‘GHC.Generics’
 (:*:) ∷ ∀ {g ∷ ★ → ★} {p} {f ∷ ★ → ★}. f p → g p → (:*:) f g p
+Rep ∷ ★ → ★ → ★
+M1 ∷ ∀ k. ★ → Meta → (k → ★) → k → ★
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index b89d1c48fd..08ae3a2e87 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -267,5 +267,5 @@ test('T12091',
 test('T12523', normal, ghci_script, ['T12523.script'])
 test('T12024', normal, ghci_script, ['T12024.script'])
 test('T12447', expect_broken(12447), ghci_script, ['T12447.script'])
-test('T12550', expect_broken(12550), ghci_script, ['T12550.script'])
 test('T10249', normal, ghci_script, ['T10249.script'])
+test('T12550', normal, ghci_script, ['T12550.script'])