Pretty-printing of the * kind

Before this patch, GHC always printed the * kind unparenthesized.

This led to two issues:

1. Sometimes GHC printed invalid or incorrect code.
   For example, GHC would print:  type F @*   x = x
         when it meant to print:  type F @(*) x = x
   In the former case, instead of a kind application we were getting a
   type operator (@*).

2. Sometimes GHC printed kinds that were correct but hard to read.
   Should  Either * Int  be read as  Either (*) Int
                              or as  (*) Either Int  ?
   This depends on whether -XStarIsType is enabled, but it would be
   easier if we didn't have to check for the flag when reading the code.

We can solve both problems by assigning (*) a different precedence. Note
that Haskell98 kinds are not affected:

  ((* -> *) -> *) -> *  does NOT become  (((*) -> (*)) -> (*)) -> (*)

The parentheses are added when (*) is used in a function argument
position:

   F * * *   becomes  F (*) (*) (*)
   F A * B   becomes  F A (*) B
   Proxy *   becomes  Proxy (*)
   a * -> *  becomes  a (*) -> *

5 files changed, 46 insertions, 15 deletions

diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs
index e92928c78f..324b1dd3d2 100644
--- a/compiler/GHC/Hs/Types.hs
+++ b/compiler/GHC/Hs/Types.hs
@@ -1676,7 +1676,7 @@ hsTypeNeedsParens p = go
     go (HsExplicitTupleTy{}) = False
     go (HsTyLit{})           = False
     go (HsWildCardTy{})      = False
-    go (HsStarTy{})          = False
+    go (HsStarTy{})          = p >= starPrec
     go (HsAppTy{})           = p >= appPrec
     go (HsAppKindTy{})       = p >= appPrec
     go (HsOpTy{})            = p >= opPrec
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index 7513e08f82..ce449b3562 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -51,7 +51,8 @@ module BasicTypes(
 
         Boxity(..), isBoxed,
 
-        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,
+        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec,
+        maybeParen,
 
         TupleSort(..), tupleSortBoxity, boxityTupleSort,
         tupleParens,
@@ -729,14 +730,16 @@ pprSafeOverlap False = empty
 newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show)
 -- See Note [Precedence in types]
 
-topPrec, sigPrec, funPrec, opPrec, appPrec :: PprPrec
+topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec
 topPrec = PprPrec 0 -- No parens
 sigPrec = PprPrec 1 -- Explicit type signatures
 funPrec = PprPrec 2 -- Function args; no parens for constructor apps
                     -- See [Type operator precedence] for why both
                     -- funPrec and opPrec exist.
 opPrec  = PprPrec 2 -- Infix operator
-appPrec = PprPrec 3 -- Constructor args; no parens for atomic
+starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *)
+                     -- See Note [Star kind precedence]
+appPrec  = PprPrec 4 -- Constructor args; no parens for atomic
 
 maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc
 maybeParen ctxt_prec inner_prec pretty
@@ -775,6 +778,33 @@ By treating opPrec = funPrec we end up with more parens
 
 But the two are different constructors of PprPrec so we could make
 (->) bind more or less tightly if we wanted.
+
+Note [Star kind precedence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We parenthesize the (*) kind to avoid two issues:
+
+1. Printing invalid or incorrect code.
+   For example, instead of  type F @(*) x = x
+         GHC used to print  type F @*   x = x
+   However, (@*) is a type operator, not a kind application.
+
+2. Printing kinds that are correct but hard to read.
+   Should  Either * Int  be read as  Either (*) Int
+                              or as  (*) Either Int  ?
+   This depends on whether -XStarIsType is enabled, but it would be
+   easier if we didn't have to check for the flag when reading the code.
+
+At the same time, we cannot parenthesize (*) blindly.
+Consider this Haskell98 kind:          ((* -> *) -> *) -> *
+With parentheses, it is less readable: (((*) -> (*)) -> (*)) -> (*)
+
+The solution is to assign a special precedence to (*), 'starPrec', which is
+higher than 'funPrec' but lower than 'appPrec':
+
+   F * * *   becomes  F (*) (*) (*)
+   F A * B   becomes  F A (*) B
+   Proxy *   becomes  Proxy (*)
+   a * -> *  becomes  a (*) -> *
 -}
 
 {-
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index db3157f39b..d649be701b 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -1315,7 +1315,7 @@ pprTyTcApp' ctxt_prec tc tys dflags style
   | tc `ifaceTyConHasKey` tYPETyConKey
   , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys
   , rep `ifaceTyConHasKey` liftedRepDataConKey
-  = kindType
+  = ppr_kind_type ctxt_prec
 
   | otherwise
   = getPprDebug $ \dbg ->
@@ -1332,6 +1332,14 @@ pprTyTcApp' ctxt_prec tc tys dflags style
     info = ifaceTyConInfo tc
     tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags tys
 
+ppr_kind_type :: PprPrec -> SDoc
+ppr_kind_type ctxt_prec =
+  sdocWithDynFlags $ \dflags ->
+    if useStarIsType dflags
+    then maybeParen ctxt_prec starPrec $
+         unicodeSyntax (char '★') (char '*')
+    else text "Type"
+
 -- | Pretty-print a type-level equality.
 -- Returns (Just doc) if the argument is a /saturated/ application
 -- of   eqTyCon          (~)
@@ -1440,7 +1448,7 @@ ppr_iface_tc_app pp _ tc [ty]
 
 ppr_iface_tc_app pp ctxt_prec tc tys
   | tc `ifaceTyConHasKey` liftedTypeKindTyConKey
-  = kindType
+  = ppr_kind_type ctxt_prec
 
   | not (isSymOcc (nameOccName (ifaceTyConName tc)))
   = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys)
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index bed4ae2fd1..6f9bdc5138 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -13,7 +13,6 @@ pprCols                  :: DynFlags -> Int
 unsafeGlobalDynFlags     :: DynFlags
 useUnicode               :: DynFlags -> Bool
 useUnicodeSyntax         :: DynFlags -> Bool
-useStarIsType            :: DynFlags -> Bool
 shouldUseColor           :: DynFlags -> Bool
 shouldUseHexWordLiterals :: DynFlags -> Bool
 hasPprDebug              :: DynFlags -> Bool
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index bbc365b774..0dda99020f 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -28,7 +28,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, kindType, bullet,
+        blankLine, forAllLit, bullet,
         (<>), (<+>), hcat, hsep,
         ($$), ($+$), vcat,
         sep, cat,
@@ -91,7 +91,7 @@ import GhcPrelude
 
 import {-# SOURCE #-}   DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,
                                   targetPlatform, pprUserLength, pprCols,
-                                  useUnicode, useUnicodeSyntax, useStarIsType,
+                                  useUnicode, useUnicodeSyntax,
                                   shouldUseColor, unsafeGlobalDynFlags,
                                   shouldUseHexWordLiterals )
 import {-# SOURCE #-}   Module( UnitId, Module, ModuleName, moduleName )
@@ -649,12 +649,6 @@ rbrace     = docToSDoc $ Pretty.rbrace
 forAllLit :: SDoc
 forAllLit = unicodeSyntax (char '∀') (text "forall")
 
-kindType :: SDoc
-kindType = sdocWithDynFlags $ \dflags ->
-    if useStarIsType dflags
-    then unicodeSyntax (char '★') (char '*')
-    else text "Type"
-
 bullet :: SDoc
 bullet = unicode (char '•') (char '*')