Commit ae2c9b40 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Smarter HsType pretty-print for promoted datacons

Fix Trac #15898, by being smarter about when to print
a space before a promoted data constructor, in a HsType.
I had to implement a mildly tiresome function
    HsType.lhsTypeHasLeadingPromotionQuote
It has multiple cases, of course, but it's very simple.

The patch improves the error-message output in a bunch of
cases, and (to my surprise) actually fixes a bug in the
output of T14343 (Trac #14343), thus

  -  In the expression: _ :: Proxy '('( 'True,  'False),  'False)
  +  In the expression: _ :: Proxy '( '( 'True, 'False), 'False)

I discovered that there were two copies of the PromotionFlag
type (a boolean, with helpfully named data cons), one in
IfaceType and one in HsType.  So I combined into one,
PromotionFlag, and moved it to BasicTypes.  That's why
quite a few files are touched, but it's all routine.
parent 0ce66be9
......@@ -28,6 +28,7 @@ module BasicTypes(
Alignment,
PromotionFlag(..), isPromoted,
FunctionOrData(..),
WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),
......@@ -270,6 +271,24 @@ unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
unSwap NotSwapped f a b = f a b
unSwap IsSwapped f a b = f b a
{- *********************************************************************
* *
Promotion flag
* *
********************************************************************* -}
-- | Is a TyCon a promoted data constructor or just a normal type constructor?
data PromotionFlag
= NotPromoted
| IsPromoted
deriving ( Eq, Data )
isPromoted :: PromotionFlag -> Bool
isPromoted IsPromoted = True
isPromoted NotPromoted = False
{-
************************************************************************
* *
......
......@@ -1350,7 +1350,7 @@ cvtTypeKind ty_str ty
-- names, as opposed to PromotedT, which can only
-- contain data constructor names. See #15572.
let prom = if isRdrDataCon nm'
then Promoted
then IsPromoted
else NotPromoted
; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}
......@@ -1398,8 +1398,8 @@ cvtTypeKind ty_str ty
}
PromotedT nm -> do { nm' <- cName nm
; mk_apps (HsTyVar noExt Promoted
(noLoc nm')) tys' }
; let hs_ty = HsTyVar noExt IsPromoted (noLoc nm')
; mk_apps hs_ty tys' }
-- Promoted data constructor; hence cName
PromotedTupleT n
......@@ -1408,20 +1408,20 @@ cvtTypeKind ty_str ty
| m == n -- Saturated
-> returnL (HsExplicitTupleTy noExt tys')
| otherwise
-> mk_apps (HsTyVar noExt Promoted
-> mk_apps (HsTyVar noExt IsPromoted
(noLoc (getRdrName (tupleDataCon Boxed n)))) tys'
where
m = length tys'
PromotedNilT
-> mk_apps (HsExplicitListTy noExt Promoted []) tys'
-> mk_apps (HsExplicitListTy noExt IsPromoted []) tys'
PromotedConsT -- See Note [Representing concrete syntax in types]
-- in Language.Haskell.TH.Syntax
| [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
-> returnL (HsExplicitListTy noExt ip (ty1:tys2))
| otherwise
-> mk_apps (HsTyVar noExt Promoted
-> mk_apps (HsTyVar noExt IsPromoted
(noLoc (getRdrName consDataCon)))
tys'
......
......@@ -24,7 +24,6 @@ module HsTypes (
HsWildCardBndrs(..),
LHsSigType, LHsSigWcType, LHsWcType,
HsTupleSort(..),
Promoted(..),
HsContext, LHsContext,
HsTyLit(..),
HsIPName(..), hsIPNameFS,
......@@ -515,10 +514,10 @@ data HsType pass
, hst_ctxt :: LHsContext pass -- Context C => blah
, hst_body :: LHsType pass }
| HsTyVar (XTyVar pass)
Promoted -- whether explicitly promoted, for the pretty
-- printer
(Located (IdP pass))
| HsTyVar (XTyVar pass)
PromotionFlag -- Whether explicitly promoted,
-- for the pretty printer
(Located (IdP pass))
-- Type variable, type constructor, or data constructor
-- see Note [Promotions (HsTyVar)]
-- See Note [Located RdrNames] in HsExpr
......@@ -641,7 +640,7 @@ data HsType pass
| HsExplicitListTy -- A promoted explicit list
(XExplicitListTy pass)
Promoted -- whether explcitly promoted, for pretty printer
PromotionFlag -- whether explcitly promoted, for pretty printer
[LHsType pass]
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,
-- 'ApiAnnotation.AnnClose' @']'@
......@@ -854,12 +853,6 @@ data HsTupleSort = HsUnboxedTuple
| HsBoxedOrConstraintTuple
deriving Data
-- | Promoted data types.
data Promoted = Promoted
| NotPromoted
deriving (Data, Eq, Show)
-- | Located Constructor Declaration Field
type LConDeclField pass = Located (ConDeclField pass)
-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when
......@@ -1401,11 +1394,9 @@ ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty })
ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty
ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds
ppr_mono_ty (HsTyVar _ NotPromoted (L _ name))= pprPrefixOcc name
ppr_mono_ty (HsTyVar _ Promoted (L _ name))
= space <> quote (pprPrefixOcc name)
-- We need a space before the ' above, so the parser
-- does not attach it to the previous symbol
ppr_mono_ty (HsTyVar _ prom (L _ name))
| isPromoted prom = quote (pprPrefixOcc name)
| otherwise = pprPrefixOcc name
ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2
ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys)
where std_con = case con of
......@@ -1418,11 +1409,11 @@ ppr_mono_ty (HsKindSig _ ty kind)
ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty)
ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty)
ppr_mono_ty (HsSpliceTy _ s) = pprSplice s
ppr_mono_ty (HsExplicitListTy _ Promoted tys)
= quote $ brackets (interpp'SP tys)
ppr_mono_ty (HsExplicitListTy _ NotPromoted tys)
= brackets (interpp'SP tys)
ppr_mono_ty (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
ppr_mono_ty (HsExplicitListTy _ prom tys)
| isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)
| otherwise = brackets (interpp'SP tys)
ppr_mono_ty (HsExplicitTupleTy _ tys)
= quote $ parens (maybeAddSpace tys $ interpp'SP tys)
ppr_mono_ty (HsTyLit _ t) = ppr_tylit t
ppr_mono_ty (HsWildCardTy {}) = char '_'
......@@ -1492,6 +1483,46 @@ hsTypeNeedsParens p = go
go (HsDocTy _ (L _ t) _) = go t
go (XHsType{}) = False
maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc
-- See Note [Printing promoted type constructors]
-- in IfaceType. This code implements the same
-- logic for printing HsType
maybeAddSpace tys doc
| (ty : _) <- tys
, lhsTypeHasLeadingPromotionQuote ty = space <> doc
| otherwise = doc
lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool
lhsTypeHasLeadingPromotionQuote ty
= goL ty
where
goL (L _ ty) = go ty
go (HsForAllTy{}) = False
go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})
| L _ (c:_) <- ctxt = goL c
| otherwise = goL body
go (HsBangTy{}) = False
go (HsRecTy{}) = False
go (HsTyVar _ p _) = isPromoted p
go (HsFunTy _ arg _) = goL arg
go (HsListTy{}) = False
go (HsTupleTy{}) = False
go (HsSumTy{}) = False
go (HsOpTy _ t1 _ _) = goL t1
go (HsKindSig _ t _) = goL t
go (HsIParamTy{}) = False
go (HsSpliceTy{}) = False
go (HsExplicitListTy _ p _) = isPromoted p
go (HsExplicitTupleTy{}) = True
go (HsTyLit{}) = False
go (HsWildCardTy{}) = False
go (HsStarTy{}) = False
go (HsAppTy _ t _) = goL t
go (HsParTy{}) = False
go (HsDocTy _ t _) = goL t
go (XHsType{}) = False
-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is
-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply
-- returns @ty@.
......
......@@ -16,7 +16,7 @@ module IfaceType (
IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
IfaceMCoercion(..),
IfaceUnivCoProv(..),
IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), IsPromoted(..),
IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..),
IfaceTyLit(..), IfaceAppArgs(..),
IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
......@@ -143,7 +143,7 @@ data IfaceType
| IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp)
TupleSort -- What sort of tuple?
IsPromoted -- A bit like IfaceTyCon
PromotionFlag -- A bit like IfaceTyCon
IfaceAppArgs -- arity = length args
-- For promoted data cons, the kind args are omitted
......@@ -186,10 +186,6 @@ data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName
, ifaceTyConInfo :: IfaceTyConInfo }
deriving (Eq)
-- | Is a TyCon a promoted data constructor or just a normal type constructor?
data IsPromoted = IsNotPromoted | IsPromoted
deriving (Eq)
-- | The various types of TyCons which have special, built-in syntax.
data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon
......@@ -290,7 +286,7 @@ See Note [The equality types story] in TysPrim.
data IfaceTyConInfo -- Used to guide pretty-printing
-- and to disambiguate D from 'D (they share a name)
= IfaceTyConInfo { ifaceTyConIsPromoted :: IsPromoted
= IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag
, ifaceTyConSort :: IfaceTyConSort }
deriving (Eq)
......@@ -1033,11 +1029,24 @@ criteria are met:
in TyCoRep.
N.B. Until now (Aug 2018) we didn't check anything for coercion variables.
Note [Printing promoted type constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this GHCi session (Trac #14343)
> _ :: Proxy '[ 'True ]
error:
Found hole: _ :: Proxy '['True]
This would be bad, because the '[' looks like a character literal.
Solution: in type-level lists and tuples, add a leading space
if the first type is itself promoted. See pprSpaceIfPromotedTyCon.
-}
-------------------
-- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'.
-- See Note [Printing promoted type constructors]
pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc
pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _)
= case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of
......@@ -1229,7 +1238,7 @@ ppr_iface_tc_app pp ctxt_prec tc tys
| otherwise
= pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys)
pprSum :: Arity -> IsPromoted -> IfaceAppArgs -> SDoc
pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc
pprSum _arity is_promoted args
= -- drop the RuntimeRep vars.
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
......@@ -1238,8 +1247,8 @@ pprSum _arity is_promoted args
in pprPromotionQuoteI is_promoted
<> sumParens (pprWithBars (ppr_ty topPrec) args')
pprTuple :: PprPrec -> TupleSort -> IsPromoted -> IfaceAppArgs -> SDoc
pprTuple ctxt_prec ConstraintTuple IsNotPromoted IA_Nil
pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc
pprTuple ctxt_prec ConstraintTuple NotPromoted IA_Nil
= maybeParen ctxt_prec appPrec $
text "() :: Constraint"
......@@ -1375,8 +1384,8 @@ pprPromotionQuote :: IfaceTyCon -> SDoc
pprPromotionQuote tc =
pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc
pprPromotionQuoteI :: IsPromoted -> SDoc
pprPromotionQuoteI IsNotPromoted = empty
pprPromotionQuoteI :: PromotionFlag -> SDoc
pprPromotionQuoteI NotPromoted = empty
pprPromotionQuoteI IsPromoted = char '\''
instance Outputable IfaceCoercion where
......@@ -1389,17 +1398,6 @@ instance Binary IfaceTyCon where
i <- get bh
return (IfaceTyCon n i)
instance Binary IsPromoted where
put_ bh IsNotPromoted = putByte bh 0
put_ bh IsPromoted = putByte bh 1
get bh = do
n <- getByte bh
case n of
0 -> return IsNotPromoted
1 -> return IsPromoted
_ -> fail "Binary(IsPromoted): fail)"
instance Binary IfaceTyConSort where
put_ bh IfaceNormalTyCon = putByte bh 0
put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort
......
......@@ -1153,13 +1153,13 @@ tcIfaceType = go
go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co
go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co
tcIfaceTupleTy :: TupleSort -> IsPromoted -> IfaceAppArgs -> IfL Type
tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type
tcIfaceTupleTy sort is_promoted args
= do { args' <- tcIfaceAppArgs args
; let arity = length args'
; base_tc <- tcTupleTyCon True sort arity
; case is_promoted of
IsNotPromoted
NotPromoted
-> return (mkTyConApp base_tc args')
IsPromoted
......@@ -1673,7 +1673,7 @@ tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon (IfaceTyCon name info)
= do { thing <- tcIfaceGlobal name
; return $ case ifaceTyConIsPromoted info of
IsNotPromoted -> tyThingTyCon thing
NotPromoted -> tyThingTyCon thing
IsPromoted -> promoteDataCon $ tyThingDataCon thing }
tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
......
......@@ -150,7 +150,7 @@ toIfaceTypeX fr (TyConApp tc tys)
-- tuples
| Just sort <- tyConTuple_maybe tc
, n_tys == arity
= IfaceTupleTy sort IsNotPromoted (toIfaceTcArgsX fr tc tys)
= IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys)
| Just dc <- isPromotedDataCon_maybe tc
, isTupleDataCon dc
......@@ -159,7 +159,7 @@ toIfaceTypeX fr (TyConApp tc tys)
| tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]
, (k1:k2:_) <- tys
= let info = IfaceTyConInfo IsNotPromoted sort
= let info = IfaceTyConInfo NotPromoted sort
sort | k1 `eqType` k2 = IfaceEqualityTyCon
| otherwise = IfaceNormalTyCon
in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)
......@@ -191,7 +191,7 @@ toIfaceTyCon tc
tc_name = tyConName tc
info = IfaceTyConInfo promoted sort
promoted | isPromotedDataCon tc = IsPromoted
| otherwise = IsNotPromoted
| otherwise = NotPromoted
tupleSort :: TyCon -> Maybe IfaceTyConSort
tupleSort tc' =
......@@ -217,7 +217,7 @@ toIfaceTyCon tc
toIfaceTyCon_name :: Name -> IfaceTyCon
toIfaceTyCon_name n = IfaceTyCon n info
where info = IfaceTyConInfo IsNotPromoted IfaceNormalTyCon
where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon
-- Used for the "rough-match" tycon stuff,
-- where pretty-printing is not an issue
......
......@@ -2030,14 +2030,14 @@ atype :: { LHsType GhcPs }
(sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))
[mj AnnThIdSplice $1] }
-- see Note [Promotion] for the followings
| SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
| SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExt IsPromoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }
| SIMPLEQUOTE '(' ktype ',' comma_types1 ')'
{% addAnnotation (gl $3) AnnComma (gl $4) >>
ams (sLL $1 $> $ HsExplicitTupleTy noExt ($3 : $5))
[mj AnnSimpleQuote $1,mop $2,mcp $6] }
| SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExt Promoted $3)
| SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy noExt IsPromoted $3)
[mj AnnSimpleQuote $1,mos $2,mcs $4] }
| SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExt Promoted $2)
| SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar noExt IsPromoted $2)
[mj AnnSimpleQuote $1,mj AnnName $2] }
-- Two or more [ty, ty, ty] must be a promoted list type, just as
......
......@@ -945,6 +945,17 @@ instance Binary LeftOrRight where
0 -> return CLeft
_ -> return CRight }
instance Binary PromotionFlag where
put_ bh NotPromoted = putByte bh 0
put_ bh IsPromoted = putByte bh 1
get bh = do
n <- getByte bh
case n of
0 -> return NotPromoted
1 -> return IsPromoted
_ -> fail "Binary(IsPromoted): fail)"
instance Binary Fingerprint where
put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
......
......@@ -2,5 +2,5 @@
PromotedClass.hs:10:15: error:
• Data constructor ‘MkX’ cannot be used here
(it has an unpromotable context ‘Show a’)
• In the first argument of ‘Proxy’, namely ‘( 'MkX 'True)’
In the type signature: foo :: Proxy ( 'MkX 'True)
• In the first argument of ‘Proxy’, namely ‘('MkX 'True)’
In the type signature: foo :: Proxy ('MkX 'True)
......@@ -2,6 +2,6 @@
T15245.hs:10:24: error:
• Data constructor ‘MkK’ cannot be used here
(it comes from a data family instance)
• In the type ‘ 'MkK’
In the first argument of ‘print’, namely ‘(typeRep @ 'MkK)’
In the expression: print (typeRep @ 'MkK)
• In the type ‘'MkK’
In the first argument of ‘print’, namely ‘(typeRep @'MkK)’
In the expression: print (typeRep @'MkK)
:set -XDataKinds
import Data.Proxy
undefined :: '()
undefined :: Proxy '() Int
undefined :: [(), ()]
undefined :: '( '[], '[] )
......@@ -288,3 +288,4 @@ test('T15568', normal, ghci_script, ['T15568.script'])
test('T15325', normal, ghci_script, ['T15325.script'])
test('T15591', normal, ghci_script, ['T15591.script'])
test('T15743b', normal, ghci_script, ['T15743b.script'])
test('T15898', normal, ghci_script, ['T15898.script'])
......@@ -145,7 +145,7 @@
[({ DumpParsedAst.hs:9:10-12 }
(HsExplicitListTy
(NoExt)
(Promoted)
(IsPromoted)
[]))]
(Prefix)
({ DumpParsedAst.hs:9:21-24 }
......
......@@ -191,7 +191,7 @@
[({ DumpRenamedAst.hs:12:10-12 }
(HsExplicitListTy
(NoExt)
(Promoted)
(IsPromoted)
[]))]
(Prefix)
({ DumpRenamedAst.hs:12:21-24 }
......
......@@ -377,7 +377,7 @@
({ KindSigs.hs:26:13-29 }
(HsExplicitListTy
(NoExt)
(Promoted)
(IsPromoted)
[({ KindSigs.hs:26:16-27 }
(HsKindSig
(NoExt)
......
PolyKinds07.hs:10:11:
Data constructor ‘A1’ cannot be used here
(it is defined and used in the same recursive group)
In the first argument of ‘B’, namely ‘ 'A1’
In the type ‘B 'A1’
In the definition of data constructor ‘B1’
PolyKinds07.hs:10:11: error:
Data constructor ‘A1’ cannot be used here
(it is defined and used in the same recursive group)
In the first argument of ‘B’, namely ‘'A1’
In the type ‘B 'A1’
In the definition of data constructor ‘B1’
......@@ -13,5 +13,5 @@ T10503.hs:8:6: error:
To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
In the type signature:
h :: forall r.
(Proxy ( 'KProxy :: KProxy k) ~ Proxy ( 'KProxy :: KProxy *) => r)
(Proxy ('KProxy :: KProxy k) ~ Proxy ('KProxy :: KProxy *) => r)
-> r
......@@ -2,6 +2,6 @@
T15116a.hs:6:21: error:
• Data constructor ‘MkB’ cannot be used here
(it is defined and used in the same recursive group)
• In the first argument of ‘Proxy’, namely ‘ 'MkB’
In the type ‘(Proxy 'MkB)’
• In the first argument of ‘Proxy’, namely ‘'MkB’
In the type ‘(Proxy 'MkB)’
In the definition of data constructor ‘MkB’
......@@ -2,5 +2,5 @@
T7433.hs:2:10: error:
• Data constructor ‘Z’ cannot be used here
(perhaps you intended to use DataKinds)
• In the type ‘ 'Z’
• In the type ‘'Z’
In the type declaration for ‘T’
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment