summaryrefslogtreecommitdiff
path: root/compiler/parser
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/parser')
-rw-r--r--compiler/parser/Lexer.x31
-rw-r--r--compiler/parser/Parser.y.pp26
-rw-r--r--compiler/parser/ParserCore.y7
-rw-r--r--compiler/parser/RdrHsSyn.lhs8
4 files changed, 59 insertions, 13 deletions
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 11d849ab71..c97d38f506 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -362,14 +362,14 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") }
@qual @varid { idtoken qvarid }
@qual @conid { idtoken qconid }
@varid { varid }
- @conid { idtoken conid }
+ @conid { conid }
}
<0> {
@qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
@qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
@varid "#"+ / { ifExtension magicHashEnabled } { varid }
- @conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid }
+ @conid "#"+ / { ifExtension magicHashEnabled } { conid }
}
-- ToDo: - move `var` and (sym) into lexical syntax?
@@ -475,6 +475,9 @@ data Token
| ITgroup
| ITby
| ITusing
+ | ITnominal
+ | ITrepresentational
+ | ITphantom
-- Pragmas
| ITinline_prag InlineSpec RuleMatchInfo
@@ -669,6 +672,14 @@ 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 )
+ ]
+
reservedSymsFM :: UniqFM (Token, Int -> Bool)
reservedSymsFM = listToUFM $
map (\ (x,y,z) -> (mkFastString x,(y,z)))
@@ -1014,8 +1025,20 @@ varid span buf len =
where
!fs = lexemeToFastString buf len
-conid :: StringBuffer -> Int -> Token
-conid buf len = ITconid $! 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
qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token
qvarsym buf len = ITqvarsym $! splitQualName buf len False
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index af297531e2..b35bbf38b4 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -59,6 +59,7 @@ 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 )
@@ -273,6 +274,9 @@ 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 }
@@ -1129,6 +1133,7 @@ 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 $
@@ -1166,8 +1171,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr RdrName }
- : tyvar { L1 (UserTyVar (unLoc $1)) }
- | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) }
+ : tyvar { L1 (HsTyVarBndr (unLoc $1) Nothing Nothing) }
+ | '(' tyvar '::' kind ')' { LL (HsTyVarBndr (unLoc $2) (Just $4) Nothing) }
fds :: { Located [Located (FunDep RdrName)] }
: {- empty -} { noLoc [] }
@@ -1185,6 +1190,11 @@ 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
@@ -1926,7 +1936,7 @@ qtycon :: { Located RdrName } -- Qualified or unqualified
| tycon { $1 }
tycon :: { Located RdrName } -- Unqualified
- : CONID { L1 $! mkUnqual tcClsName (getCONID $1) }
+ : upcase_id { L1 $! mkUnqual tcClsName (unLoc $1) }
qtyconsym :: { Located RdrName }
: QCONSYM { L1 $! mkQual tcClsName (getQCONSYM $1) }
@@ -2071,7 +2081,7 @@ qconid :: { Located RdrName } -- Qualified or unqualified
| PREFIXQCONSYM { L1 $! mkQual dataName (getPREFIXQCONSYM $1) }
conid :: { Located RdrName }
- : CONID { L1 $ mkUnqual dataName (getCONID $1) }
+ : upcase_id { L1 $ mkUnqual dataName (unLoc $1) }
qconsym :: { Located RdrName } -- Qualified or unqualified
: consym { $1 }
@@ -2108,7 +2118,7 @@ close :: { () }
-- Miscellaneous (mostly renamings)
modid :: { Located ModuleName }
- : CONID { L1 $ mkModuleNameFS (getCONID $1) }
+ : upcase_id { L1 $ mkModuleNameFS (unLoc $1) }
| QCONID { L1 $ let (mod,c) = getQCONID $1 in
mkModuleNameFS
(mkFastString
@@ -2119,6 +2129,12 @@ 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
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index 0e78794515..2a4c957039 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -270,7 +270,10 @@ exp :: { IfaceExpr }
-- gaw 2004
| '%case' '(' ty ')' aexp '%of' id_bndr
'{' alts1 '}' { IfaceCase $5 (fst $7) $9 }
- | '%cast' aexp aty { IfaceCast $2 $3 }
+-- The following line is broken and is hard to fix. Not fixing now
+-- because this whole parser is bitrotten anyway.
+-- Richard Eisenberg, July 2013
+-- | '%cast' aexp aty { IfaceCast $2 $3 }
-- No InlineMe any more
-- | '%note' STRING exp
-- { case $2 of
@@ -375,7 +378,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
-toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
+toHsTvBndr (tv,k) = noLoc $ HsTyVarBndr (mkRdrUnqual (mkTyVarOccFS tv)) (Just bsig) Nothing
where
bsig = toHsKind k
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index e8c23cad52..1e61cf9f4f 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -465,10 +465,14 @@ checkTyVars tycl_hdr tparms = do { tvs <- mapM chk tparms
; return (mkHsQTvs tvs) }
where
-- Check that the name space is correct!
+ chk (L l (HsRoleAnnot (L _ (HsKindSig (L _ (HsTyVar tv)) k)) r))
+ | isRdrTyVar tv = return (L l (HsTyVarBndr tv (Just k) (Just r)))
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
- | isRdrTyVar tv = return (L l (KindedTyVar tv k))
+ | isRdrTyVar tv = return (L l (HsTyVarBndr tv (Just k) Nothing))
+ chk (L l (HsRoleAnnot (L _ (HsTyVar tv)) r))
+ | isRdrTyVar tv = return (L l (HsTyVarBndr tv Nothing (Just r)))
chk (L l (HsTyVar tv))
- | isRdrTyVar tv = return (L l (UserTyVar tv))
+ | isRdrTyVar tv = return (L l (HsTyVarBndr tv Nothing Nothing))
chk t@(L l _)
= parseErrorSDoc l $
vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
View Lorry Controller Status