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

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