Commit f4046b50 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Change role annotation syntax.

This fixes bugs #8185, #8234, and #8246. The new syntax is explained
in the comments to #8185, appears in the "Roles" subsection of the
manual, and on the [wiki:Roles] wiki page.

This change also removes the ability for a role annotation on type
synonyms, as noted in #8234.
parent 96421e06
This diff is collapsed.
......@@ -267,6 +267,11 @@ cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
; returnL $ TyClD (FamDecl (FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind')) }
| otherwise
= failWith (ptext (sLit "Illegal empty closed type family"))
cvtDec (TH.RoleAnnotD tc roles)
= do { tc' <- tconNameL tc
; let roles' = map (noLoc . cvtRole) roles
; return $ noLoc $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
......@@ -856,25 +861,17 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tName nm
; returnL $ HsTyVarBndr nm' Nothing Nothing }
; returnL $ UserTyVar nm' }
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; ki' <- cvtKind ki
; returnL $ HsTyVarBndr nm' (Just ki') Nothing }
cvt_tv (TH.RoledTV nm r)
= do { nm' <- tName nm
; r' <- cvtRole r
; returnL $ HsTyVarBndr nm' Nothing (Just r') }
cvt_tv (TH.KindedRoledTV nm k r)
= do { nm' <- tName nm
; k' <- cvtKind k
; r' <- cvtRole r
; returnL $ HsTyVarBndr nm' (Just k') (Just r') }
cvtRole :: TH.Role -> CvtM Coercion.Role
cvtRole TH.Nominal = return Coercion.Nominal
cvtRole TH.Representational = return Coercion.Representational
cvtRole TH.Phantom = return Coercion.Phantom
; returnL $ KindedTyVar nm' ki' }
cvtRole :: TH.Role -> Maybe Coercion.Role
cvtRole TH.NominalR = Just Coercion.Nominal
cvtRole TH.RepresentationalR = Just Coercion.Representational
cvtRole TH.PhantomR = Just Coercion.Phantom
cvtRole TH.InferR = Nothing
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
......
......@@ -15,7 +15,8 @@ module HsDecls (
-- * Toplevel declarations
HsDecl(..), LHsDecl, HsDataDefn(..),
-- ** Class or type declarations
TyClDecl(..), LTyClDecl, TyClGroup,
TyClDecl(..), LTyClDecl,
TyClGroup(..), tyClGroupConcat, mkTyClGroup,
isClassDecl, isDataDecl, isSynDecl, tcdName,
isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
......@@ -57,9 +58,12 @@ module HsDecls (
-- ** Annotations
AnnDecl(..), LAnnDecl,
AnnProvenance(..), annProvenanceName_maybe,
-- ** Role annotations
RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,
-- * Grouping
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups
) where
-- friends:
......@@ -116,6 +120,7 @@ data HsDecl id
| SpliceD (SpliceDecl id)
| DocD (DocDecl)
| QuasiQuoteD (HsQuasiQuote id)
| RoleAnnotD (RoleAnnotDecl id)
deriving (Data, Typeable)
......@@ -138,7 +143,7 @@ data HsGroup id
= HsGroup {
hs_valds :: HsValBinds id,
hs_tyclds :: [[LTyClDecl id]],
hs_tyclds :: [TyClGroup id],
-- A list of mutually-recursive groups
-- No family-instances here; they are in hs_instds
-- Parser generates a singleton list;
......@@ -234,6 +239,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
ppr (SpliceD dd) = ppr dd
ppr (DocD doc) = ppr doc
ppr (QuasiQuoteD qq) = ppr qq
ppr (RoleAnnotD ra) = ppr ra
instance OutputableBndr name => Outputable (HsGroup name) where
ppr (HsGroup { hs_valds = val_decls,
......@@ -255,7 +261,7 @@ instance OutputableBndr name => Outputable (HsGroup name) where
if isEmptyValBinds val_decls
then Nothing
else Just (ppr val_decls),
ppr_ds (concat tycl_decls),
ppr_ds (tyClGroupConcat tycl_decls),
ppr_ds inst_decls,
ppr_ds deriv_decls,
ppr_ds foreign_decls]
......@@ -423,9 +429,6 @@ Interface file code:
\begin{code}
type LTyClDecl name = Located (TyClDecl name)
type TyClGroup name = [LTyClDecl name] -- This is used in TcTyClsDecls to represent
-- strongly connected components of decls
-- No familiy instances in here
-- | A type or class declaration.
data TyClDecl name
......@@ -439,10 +442,10 @@ data TyClDecl name
| -- | @type@ declaration
SynDecl { tcdLName :: Located name -- ^ Type constructor
, tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an associated type
, tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an associated type
-- these include outer binders
, tcdRhs :: LHsType name -- ^ RHS of type declaration
, tcdFVs :: NameSet }
, tcdRhs :: LHsType name -- ^ RHS of type declaration
, tcdFVs :: NameSet }
| -- | @data@ declaration
DataDecl { tcdLName :: Located name -- ^ Type constructor
......@@ -467,8 +470,25 @@ data TyClDecl name
tcdDocs :: [LDocDecl], -- ^ Haddock docs
tcdFVs :: NameSet
}
deriving (Data, Typeable)
-- This is used in TcTyClsDecls to represent
-- strongly connected components of decls
-- No familiy instances in here
-- The role annotations must be grouped with their decls for the
-- type-checker to infer roles correctly
data TyClGroup name
= TyClGroup { group_tyclds :: [LTyClDecl name]
, group_roles :: [LRoleAnnotDecl name] }
deriving (Data, Typeable)
tyClGroupConcat :: [TyClGroup name] -> [LTyClDecl name]
tyClGroupConcat = concatMap group_tyclds
mkTyClGroup :: [LTyClDecl name] -> TyClGroup name
mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] }
type LFamilyDecl name = Located (FamilyDecl name)
data FamilyDecl name = FamilyDecl
{ fdInfo :: FamilyInfo name -- type or data, closed or open
......@@ -613,6 +633,11 @@ instance OutputableBndr name
<+> pp_vanilla_decl_head lclas tyvars (unLoc context)
<+> pprFundeps (map unLoc fds)
instance OutputableBndr name => Outputable (TyClGroup name) where
ppr (TyClGroup { group_tyclds = tyclds, group_roles = roles })
= ppr tyclds $$
ppr roles
instance (OutputableBndr name) => Outputable (FamilyDecl name) where
ppr (FamilyDecl { fdInfo = info, fdLName = ltycon,
fdTyVars = tyvars, fdKindSig = mb_kind})
......@@ -1383,3 +1408,32 @@ pprAnnProvenance ModuleAnnProvenance = ptext (sLit "ANN module")
pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
pprAnnProvenance (TypeAnnProvenance name) = ptext (sLit "ANN type") <+> ppr name
\end{code}
%************************************************************************
%* *
\subsection[RoleAnnot]{Role annotations}
%* *
%************************************************************************
\begin{code}
type LRoleAnnotDecl name = Located (RoleAnnotDecl name)
-- See #8185 for more info about why role annotations are
-- top-level declarations
data RoleAnnotDecl name
= RoleAnnotDecl (Located name) -- type constructor
[Located (Maybe Role)] -- optional annotations
deriving (Data, Typeable)
instance OutputableBndr name => Outputable (RoleAnnotDecl name) where
ppr (RoleAnnotDecl ltycon roles)
= ptext (sLit "type role") <+> ppr ltycon <+>
hsep (map (pp_role . unLoc) roles)
where
pp_role Nothing = underscore
pp_role (Just r) = ppr r
roleAnnotDeclName :: RoleAnnotDecl name -> name
roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name
\end{code}
\ No newline at end of file
......@@ -47,7 +47,6 @@ import Name( Name )
import RdrName( RdrName )
import DataCon( HsBang(..) )
import Type
import TyCon ( Role(..) )
import HsDoc
import BasicTypes
import SrcLoc
......@@ -181,12 +180,12 @@ instance OutputableBndr HsIPName where
pprPrefixOcc n = ppr n
data HsTyVarBndr name
= HsTyVarBndr name
(Maybe (LHsKind name)) -- See Note [Printing KindedTyVars]
(Maybe Role)
-- *** NOTA BENE *** A "monotype" in a pragma can have
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
= UserTyVar -- no explicit kinding
name
| KindedTyVar
name
(LHsKind name) -- The user-supplied kind signature
deriving (Data, Typeable)
data HsType name
......@@ -228,9 +227,6 @@ data HsType name
| HsKindSig (LHsType name) -- (ty :: kind)
(LHsKind name) -- A type with a kind signature
| HsRoleAnnot (LHsType name) -- ty@role, seen only right after parsing
Role
| HsQuasiQuoteTy (HsQuasiQuote name)
| HsSpliceTy (HsSplice name)
......@@ -420,7 +416,8 @@ hsExplicitTvs _ = []
---------------------
hsTyVarName :: HsTyVarBndr name -> name
hsTyVarName (HsTyVarBndr n _ _) = n
hsTyVarName (UserTyVar n) = n
hsTyVarName (KindedTyVar n _) = n
hsLTyVarName :: LHsTyVarBndr name -> name
hsLTyVarName = hsTyVarName . unLoc
......@@ -541,10 +538,8 @@ instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where
= sep [ ifPprDebug $ braces (interppSP kvs), interppSP tvs ]
instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
ppr (HsTyVarBndr n Nothing Nothing) = ppr n
ppr (HsTyVarBndr n (Just k) Nothing) = parens $ hsep [ppr n, dcolon, ppr k]
ppr (HsTyVarBndr n Nothing (Just r)) = ppr n <> char '@' <> ppr r
ppr (HsTyVarBndr n (Just k) (Just r)) = parens $ hsep [ppr n, dcolon, ppr k] <> char '@' <> ppr r
ppr (UserTyVar n) = ppr n
ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
instance (Outputable thing) => Outputable (HsWithBndrs thing) where
ppr (HsWB { hswb_cts = ty }) = ppr ty
......@@ -636,7 +631,6 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
HsUnboxedTuple -> UnboxedTuple
_ -> BoxedTuple
ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind)
ppr_mono_ty _ (HsRoleAnnot ty r) = ppr ty <> char '@' <> ppr r
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty)
......
......@@ -271,7 +271,7 @@ mkHsString s = HsString (mkFastString s)
-------------
userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
-- Caller sets location
userHsTyVarBndrs loc bndrs = [ L loc (HsTyVarBndr v Nothing Nothing) | v <- bndrs ]
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
\end{code}
......@@ -625,11 +625,11 @@ hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
hsForeignDeclsBinders foreign_decls
= [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name]
hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name]
-- We need to look at instance declarations too,
-- because their associated types may bind data constructors
hsTyClDeclsBinders tycl_decls inst_decls
= map unLoc (concatMap (concatMap hsLTyClDeclBinders) tycl_decls ++
= map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
concatMap (hsInstDeclBinders . unLoc) inst_decls)
-------------------
......
......@@ -31,7 +31,7 @@ module IfaceSyn (
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
-- Pretty printing
pprIfaceExpr, pprIfaceDeclHead
pprIfaceExpr
) where
#include "HsVersions.h"
......@@ -1010,20 +1010,19 @@ pprIfaceDecl (IfaceForeign {ifName = tycon})
pprIfaceDecl (IfaceSyn {ifName = tycon,
ifTyVars = tyvars,
ifRoles = roles,
ifSynRhs = IfaceSynonymTyCon mono_ty})
= hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars roles)
= hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty])
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles,
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifSynRhs = IfaceOpenSynFamilyTyCon, ifSynKind = kind })
= hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars roles)
= hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr kind)
-- this case handles both abstract and instantiated closed family tycons
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles,
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
ifSynRhs = _closedSynFamilyTyCon, ifSynKind = kind })
= hang (ptext (sLit "closed type family") <+> pprIfaceDeclHead [] tycon tyvars roles)
= hang (ptext (sLit "closed type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr kind)
pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
......@@ -1031,8 +1030,9 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
ifTyVars = tyvars, ifRoles = roles, ifCons = condecls,
ifRec = isrec, ifPromotable = is_prom,
ifAxiom = mbAxiom})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars roles)
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
4 (vcat [ pprCType cType
, pprRoles roles
, pprRec isrec <> comma <+> pp_prom
, pp_condecls tycon condecls
, pprAxiom mbAxiom])
......@@ -1048,8 +1048,9 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs,
ifRec = isrec})
= hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars roles <+> pprFundeps fds)
4 (vcat [pprRec isrec,
= hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
4 (vcat [pprRoles roles,
pprRec isrec,
sep (map ppr ats),
sep (map ppr sigs)])
......@@ -1061,6 +1062,10 @@ pprCType :: Maybe CType -> SDoc
pprCType Nothing = ptext (sLit "No C type associated")
pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType
pprRoles :: [Role] -> SDoc
pprRoles [] = empty
pprRoles roles = text "Roles:" <+> ppr roles
pprRec :: RecFlag -> SDoc
pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
......@@ -1074,10 +1079,10 @@ instance Outputable IfaceClassOp where
instance Outputable IfaceAT where
ppr (IfaceAT d defs) = hang (ppr d) 2 (vcat (map ppr defs))
pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> [Role] -> SDoc
pprIfaceDeclHead context thing tyvars roles
pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
pprIfaceDeclHead context thing tyvars
= hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
pprIfaceTvBndrsRoles tyvars roles]
pprIfaceTvBndrs tyvars]
pp_condecls :: OccName -> IfaceConDecls -> SDoc
pp_condecls _ (IfAbstractTyCon {}) = empty
......
......@@ -23,7 +23,7 @@ module IfaceType (
-- Printing
pprIfaceType, pprParendIfaceType, pprIfaceContext,
pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceTvBndrsRoles,
pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs,
pprIfaceBndrs,
tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart,
pprIfaceCoercion, pprParendIfaceCoercion
......@@ -187,11 +187,6 @@ pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
pprIfaceTvBndrsRoles :: [IfaceTvBndr] -> [Role] -> SDoc
pprIfaceTvBndrsRoles tyvars roles = sep (zipWith ppr_bndr_role tyvars roles)
where
ppr_bndr_role bndr role = pprIfaceTvBndr bndr <> char '@' <> ppr role
instance Binary IfaceBndr where
put_ bh (IfaceIdBndr aa) = do
putByte bh 0
......@@ -357,7 +352,11 @@ ppr_special_co ctxt_prec doc cos
(sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
ppr_role :: Role -> SDoc
ppr_role r = underscore <> ppr r
ppr_role r = underscore <> pp_role
where pp_role = case r of
Nominal -> char 'N'
Representational -> char 'R'
Phantom -> char 'P'
-------------------
instance Outputable IfaceTyCon where
......
......@@ -364,14 +364,14 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") }
@qual @varid { idtoken qvarid }
@qual @conid { idtoken qconid }
@varid { varid }
@conid { conid }
@conid { idtoken conid }
}
<0> {
@qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
@qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
@varid "#"+ / { ifExtension magicHashEnabled } { varid }
@conid "#"+ / { ifExtension magicHashEnabled } { conid }
@conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid }
}
-- ToDo: - move `var` and (sym) into lexical syntax?
......@@ -475,12 +475,10 @@ data Token
| ITjavascriptcallconv
| ITmdo
| ITfamily
| ITrole
| ITgroup
| ITby
| ITusing
| ITnominal
| ITrepresentational
| ITphantom
-- Pragmas
| ITinline_prag InlineSpec RuleMatchInfo
......@@ -652,7 +650,9 @@ reservedWordsFM = listToUFM $
( "forall", ITforall, bit explicitForallBit .|.
bit inRulePragBit),
( "mdo", ITmdo, bit recursiveDoBit),
( "family", ITfamily, bit tyFamBit),
-- See Note [Lexing type pseudo-keywords]
( "family", ITfamily, 0 ),
( "role", ITrole, 0 ),
( "group", ITgroup, bit transformComprehensionsBit),
( "by", ITby, bit transformComprehensionsBit),
( "using", ITusing, bit transformComprehensionsBit),
......@@ -676,13 +676,22 @@ reservedWordsFM = listToUFM $
( "proc", ITproc, bit arrowsBit)
]
reservedUpcaseWordsFM :: UniqFM (Token, Int)
reservedUpcaseWordsFM = listToUFM $
map (\(x, y, z) -> (mkFastString x, (y, z)))
[ ( "N", ITnominal, 0 ), -- no extension bit for better error msgs
( "R", ITrepresentational, 0 ),
( "P", ITphantom, 0 )
]
{-----------------------------------
Note [Lexing type pseudo-keywords]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
One might think that we wish to treat 'family' and 'role' as regular old
varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively.
But, there is no need to do so. These pseudo-keywords are not stolen syntax:
they are only used after the keyword 'type' at the top-level, where varids are
not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that
type families and role annotations are never declared without their extensions
on. In fact, by unconditionally lexing these pseudo-keywords as special, we
can get better error messages.
Also, note that these are included in the `varid` production in the parser --
a key detail to make all this work.
-------------------------------------}
reservedSymsFM :: UniqFM (Token, Int -> Bool)
reservedSymsFM = listToUFM $
......@@ -1028,20 +1037,8 @@ varid span buf len =
where
!fs = lexemeToFastString buf len
conid :: Action
conid span buf len =
case lookupUFM reservedUpcaseWordsFM fs of
Just (keyword, 0) -> return $ L span keyword
Just (keyword, exts) -> do
extsEnabled <- extension $ \i -> exts .&. i /= 0
if extsEnabled
then return $ L span keyword
else return $ L span $ ITconid fs
Nothing -> return $ L span $ ITconid fs
where
!fs = lexemeToFastString buf len
conid :: StringBuffer -> Int -> Token
conid buf len = ITconid $! lexemeToFastString buf len
qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token
qvarsym buf len = ITqvarsym $! splitQualName buf len False
......@@ -1856,8 +1853,7 @@ explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
bangPatBit :: Int
bangPatBit = 8 -- Tells the parser to understand bang-patterns
-- (doesn't affect the lexer)
tyFamBit :: Int
tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs
-- Bit #9 is available!
haddockBit :: Int
haddockBit = 10 -- Lex and parse Haddock comments
magicHashBit :: Int
......@@ -1902,6 +1898,7 @@ lambdaCaseBit :: Int
lambdaCaseBit = 30
negativeLiteralsBit :: Int
negativeLiteralsBit = 31
-- need another bit? See bit 9 above.
always :: Int -> Bool
......@@ -1918,8 +1915,6 @@ explicitForallEnabled :: Int -> Bool
explicitForallEnabled flags = testBit flags explicitForallBit
bangPatEnabled :: Int -> Bool
bangPatEnabled flags = testBit flags bangPatBit
-- tyFamEnabled :: Int -> Bool
-- tyFamEnabled flags = testBit flags tyFamBit
haddockEnabled :: Int -> Bool
haddockEnabled flags = testBit flags haddockBit
magicHashEnabled :: Int -> Bool
......@@ -2001,7 +1996,6 @@ mkPState flags buf loc =
.|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
.|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
.|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
.|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
.|. haddockBit `setBitIf` gopt Opt_Haddock flags
.|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
.|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
......
......@@ -33,7 +33,6 @@ import Type ( funTyCon )
import ForeignCall
import OccName ( varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
import CoAxiom ( Role(..) )
import SrcLoc
import Module
import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
......@@ -239,6 +238,7 @@ incorrect.
'unsafe' { L _ ITunsafe }
'mdo' { L _ ITmdo }
'family' { L _ ITfamily }
'role' { L _ ITrole }
'stdcall' { L _ ITstdcallconv }
'ccall' { L _ ITccallconv }
'capi' { L _ ITcapiconv }
......@@ -249,9 +249,6 @@ incorrect.
'group' { L _ ITgroup } -- for list transform extension
'by' { L _ ITby } -- for list transform extension
'using' { L _ ITusing } -- for list transform extension
'N' { L _ ITnominal } -- Nominal role
'R' { L _ ITrepresentational } -- Representational role
'P' { L _ ITphantom } -- Phantom role
'{-# INLINE' { L _ (ITinline_prag _ _) }
'{-# SPECIALISE' { L _ ITspec_prag }
......@@ -574,6 +571,7 @@ topdecl :: { OrdList (LHsDecl RdrName) }
| ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
| inst_decl { unitOL (L1 (InstD (unLoc $1))) }
| stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
| role_annot { unitOL (L1 (RoleAnnotD (unLoc $1))) }
| 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
| 'foreign' fdecl { unitOL (LL (unLoc $2)) }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
......@@ -783,6 +781,27 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTR
stand_alone_deriving :: { LDerivDecl RdrName }
: 'deriving' 'instance' inst_type { LL (DerivDecl $3) }
-----------------------------------------------------------------------------
-- Role annotations
role_annot :: { LRoleAnnotDecl RdrName }
role_annot : 'type' 'role' oqtycon maybe_roles
{% mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4)) }
-- Reversed!
maybe_roles :: { Located [Located (Maybe FastString)] }
maybe_roles : {- empty -} { noLoc [] }
| roles { $1 }
roles :: { Located [Located (Maybe FastString)] }
roles : role { LL [$1] }
| roles role { LL $ $2 : unLoc $1 }
-- read it in as a varid for better error messages
role :: { Located (Maybe FastString) }
role : VARID { L1 $ Just $ getVARID $1 }
| '_' { L1 Nothing }
-----------------------------------------------------------------------------
-- Nested declarations
......@@ -1109,7 +1128,6 @@ atype :: { LHsType RdrName }
| '[:' ctype ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 }
| atype '@' role { LL $ HsRoleAnnot $1 (unLoc $3) }
| quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) }
| '$(' exp ')' { LL $ mkHsSpliceTy $2 }
| TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $
......@@ -1147,8 +1165,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr RdrName }
: tyvar { L1 (HsTyVarBndr (unLoc $1) Nothing Nothing) }
| '(' tyvar '::' kind ')' { LL (HsTyVarBndr (unLoc $2) (Just $4) Nothing) }
: tyvar { L1 (UserTyVar (unLoc $1)) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) }
fds :: { Located [Located (FunDep RdrName)] }
: {- empty -} { noLoc [] }
......@@ -1166,11 +1184,6 @@ varids0 :: { Located [RdrName] }
: {- empty -} { noLoc [] }
| varids0 tyvar { LL (unLoc $2 : unLoc $1) }
role :: { Located Role }
: 'N' { LL Nominal }
| 'R' { LL Representational }
| 'P' { LL Phantom }
-----------------------------------------------------------------------------
-- Kinds
......@@ -1912,7 +1925,7 @@ qtycon :: { Located RdrName } -- Qualified or unqualified
| tycon { $1 }
tycon :: { Located RdrName } -- Unqualified
: upcase_id { L1 $! mkUnqual tcClsName (unLoc $1) }
: CONID { L1 $! mkUnqual tcClsName (getCONID $1) }
qtyconsym :: { Located RdrName }
: QCONSYM { L1 $! mkQual tcClsName (getQCONSYM $1) }
......@@ -1996,6 +2009,9 @@ qvarid :: { Located RdrName }
| QVARID { L1 $! mkQual varName (getQVARID $1) }
| PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
-- Note that 'role' and 'family' get lexed separately regardless of
-- the use of extensions. However, because they are listed here, this
-- is OK and they can be used as normal varids.
varid :: { Located RdrName }
: VARID { L1 $! mkUnqual varName (getVARID $1) }
| special_id { L1 $! mkUnqual varName (unLoc $1) }
......@@ -2004,6 +2020,7 @@ varid :: { Located RdrName }
| 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") }
| 'forall' { L1 $! mkUnqual varName (fsLit "forall") }
| 'family' { L1 $! mkUnqual varName (fsLit "family") }
| 'role' { L1 $! mkUnqual varName (fsLit "role") }
qvarsym :: { Located RdrName }
: varsym { $1 }
......@@ -2027,8 +2044,8 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
-- except 'unsafe', 'interruptible', 'forall', and 'family' whose treatment differs
-- depending on context
-- except 'unsafe', 'interruptible', 'forall', 'family', and 'role',
-- whose treatment differs depending on context
special_id :: { Located FastString }
special_id
: 'as' { L1 (fsLit "as") }
......@@ -2058,7 +2075,7 @@ qconid :: { Located RdrName } -- Qualified or unqualified
| PREFIXQCONSYM { L1 $! mkQual dataName (getPREFIXQCONSYM $1) }
conid :: { Located RdrName }
: upcase_id { L1 $ mkUnqual dataName (unLoc $1) }
: CONID { L1 $ mkUnqual dataName (getCONID $1) }
qconsym :: { Located RdrName } -- Qualified or unqualified
: consym { $1 }
......@@ -2095,7 +2112,7 @@ close :: { () }
-- Miscellaneous (mostly renamings)
modid :: { Located ModuleName }
: upcase_id { L1 $ mkModuleNameFS (unLoc $1) }
: CONID { L1 $ mkModuleNameFS (getCONID $1) }
| QCONID { L1 $ let (mod,c) = getQCONID $1 in
mkModuleNameFS
(mkFastString
......@@ -2106,12 +2123,6 @@ commas :: { Int } -- One or more commas
: commas ',' { $1 + 1 }
| ',' { 1 }
upcase_id :: { Located FastString }
: CONID { L1 $! getCONID $1 }
| 'N' { L1 (fsLit "N") }
| 'R' { L1 (fsLit "R") }
| 'P' { L1 (fsLit "P") }
-----------------------------------------------------------------------------
-- Documentation comments
......
......@@ -378,7 +378,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
toHsTvBndr (tv,k) = noLoc $ HsTyVarBndr (mkRdrUnqual (mkTyVarOccFS tv)) (Just bsig) Nothing
toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
where
bsig = toHsKind k
......
......@@ -8,6 +8,7 @@ module RdrHsSyn (
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice, mkTopSpliceDecl,
mkRoleAnnotDecl,
mkClassDecl,
mkTyData, mkFamInstData,
mkTySynonym, mkTyFamInstEqn,
......@@ -56,6 +57,7 @@ module RdrHsSyn (
import HsSyn -- Lots of it
import Class ( FunDep )
import CoAxiom ( Role, fsFromRole )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace,
rdrNameSpace )
......@@ -84,6 +86,8 @@ import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
import Data.Char
import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs )
#include "HsVersions.h"
\end{code}
......@@ -214,7 +218,6 @@ mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq
mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ expr))) = SpliceD (SpliceDecl expr Explicit)
mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit)
-- Ensure a type literal is used correctly; notably, we need the proper extension enabled,
-- and if it's an integer literal, the literal must be >= 0. This can occur with
-- -XNegativeLiterals enabled (see #8306)
......@@ -227,11 +230,39 @@ mkTyLit lit = extension typeLiteralsEnabled >>= check
check False =
parseErrorSDoc (getLoc lit)
(text "Illegal literal in type (use DataKinds to enable):" <+> ppr lit)
check True =
if not (negLit lit) then return (HsTyLit `fmap` lit)
else parseErrorSDoc (getLoc lit)
(text "Illegal literal in type (type literals must not be negative):" <+> ppr lit)
mkRoleAnnotDecl :: SrcSpan
-> Located RdrName -- type being annotated
-> [Located (Maybe FastString)] -- roles
-> P (LRoleAnnotDecl RdrName)
mkRoleAnnotDecl loc tycon roles
= do { roles' <- mapM parse_role roles
; return $ L loc $ RoleAnnotDecl tycon roles' }