summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Hs/Types.hs2
-rw-r--r--compiler/basicTypes/BasicTypes.hs36
-rw-r--r--compiler/iface/IfaceType.hs12
-rw-r--r--compiler/main/DynFlags.hs-boot1
-rw-r--r--compiler/utils/Outputable.hs10
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 '*')
View Lorry Controller Status