From 884ec3bb799d72dcca10c562277e7f31a0f1d283 Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 28 Jun 1999 15:42:35 +0000
Subject: [PATCH] [project @ 1999-06-28 15:42:33 by simonmar] Fix some pretty
subtle bugs in the lexing of qualified names.
---
ghc/compiler/parser/Lex.lhs | 19 ++++++++-----------
ghc/compiler/parser/ParseUtil.lhs | 31 ++++++++++++++++++++-----------
ghc/compiler/parser/Parser.y | 19 ++++++-------------
ghc/compiler/rename/ParseIface.y | 6 ------
4 files changed, 34 insertions(+), 41 deletions(-)
diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 25aa14c5f5a6..727039c7d8bd 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -96,15 +96,13 @@ Laziness, you know it makes sense :-)
\begin{code}
data Token
- = ITas -- Haskell keywords
- | ITcase
+ = ITcase -- Haskell keywords
| ITclass
| ITdata
| ITdefault
| ITderiving
| ITdo
| ITelse
- | IThiding
| ITif
| ITimport
| ITin
@@ -116,7 +114,6 @@ data Token
| ITmodule
| ITnewtype
| ITof
- | ITqualified
| ITthen
| ITtype
| ITwhere
@@ -245,7 +242,6 @@ pragmaKeywordsFM = listToUFM $
haskellKeywordsFM = listToUFM $
map (\ (x,y) -> (_PK_ x,y))
[( "_", ITunderscore ),
- ( "as", ITas ),
( "case", ITcase ),
( "class", ITclass ),
( "data", ITdata ),
@@ -253,7 +249,6 @@ haskellKeywordsFM = listToUFM $
( "deriving", ITderiving ),
( "do", ITdo ),
( "else", ITelse ),
- ( "hiding", IThiding ),
( "if", ITif ),
( "import", ITimport ),
( "in", ITin ),
@@ -265,7 +260,6 @@ haskellKeywordsFM = listToUFM $
( "module", ITmodule ),
( "newtype", ITnewtype ),
( "of", ITof ),
- ( "qualified", ITqualified ),
( "then", ITthen ),
( "type", ITtype ),
( "where", ITwhere ),
@@ -341,6 +335,10 @@ haskellKeySymsFM = listToUFM $
,("!", ITbang)
,(".", ITdot) -- sadly, for 'forall a . t'
]
+
+not_special_op ITminus = False
+not_special_op ITbang = False
+not_special_op _ = True
\end{code}
-----------------------------------------------------------------------------
@@ -980,8 +978,9 @@ lex_id3 cont glaexts mod buf just_a_conid
new_buf = mergeLexemes buf buf'
in
case lookupUFM haskellKeySymsFM lexeme of {
- Just kwd_token -> just_a_conid; -- avoid M.:: etc.
- Nothing -> cont (mk_qvar_token mod lexeme) new_buf
+ Just kwd_token | not_special_op kwd_token
+ -> just_a_conid; -- avoid M.::, but not M.!
+ other -> cont (mk_qvar_token mod lexeme) new_buf
}}
| otherwise =
@@ -1003,8 +1002,6 @@ lex_id3 cont glaexts mod buf just_a_conid
case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
Just kwd_token -> just_a_conid; -- avoid M.where etc.
Nothing -> is_a_qvarid
- -- TODO: special ids (as, qualified, hiding) shouldn't be
- -- recognised as keywords here. ie. M.as is a qualified varid.
}}}
diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index ce4f71bfcfb9..2be5030193f9 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -14,6 +14,10 @@ module ParseUtil (
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
, groupBindings
+ , checkAs
+ , checkHiding
+ , checkQualified
+
, checkPrec -- String -> P String
, checkCallConv -- FAST_STRING -> P CallConv
, checkContext -- HsType -> P HsContext
@@ -33,10 +37,9 @@ module ParseUtil (
, funTyCon_RDR
-- pseudo-keywords, in var and tyvar forms (all :: RdrName)
- , as_var_RDR, hiding_var_RDR, qualified_var_RDR, forall_var_RDR
+ , forall_var_RDR
, export_var_RDR, label_var_RDR, dynamic_var_RDR, unsafe_var_RDR
- , as_tyvar_RDR, hiding_tyvar_RDR, qualified_tyvar_RDR
, export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR
, unsafe_tyvar_RDR
@@ -69,6 +72,9 @@ parseError s =
getSrcLocP `thenP` \ loc ->
failMsgP (hcat [ppr loc, text ": ", text s])
+parseErrorOnInput :: P a
+parseErrorOnInput buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
+
srcParseErr :: StringBuffer -> SrcLoc -> Message
srcParseErr s l
= hcat [ppr l, ptext SLIT(": parse error on input "),
@@ -76,6 +82,18 @@ srcParseErr s l
cbot = panic "CCall:result_ty"
+-----------------------------------------------------------------------------
+-- Special Ids
+
+checkAs, checkQualified, checkHiding :: FAST_STRING -> P ()
+
+checkAs s | s == SLIT("as") = returnP ()
+ | otherwise = parseErrorOnInput
+checkQualified s | s == SLIT("qualified") = returnP ()
+ | otherwise = parseErrorOnInput
+checkHiding s | s == SLIT("hiding") = returnP ()
+ | otherwise = parseErrorOnInput
+
-----------------------------------------------------------------------------
-- splitForConApp
@@ -428,27 +446,18 @@ unitName = SLIT("()")
funName = SLIT("(->)")
listName = SLIT("[]")
-asName = SLIT("as")
-hidingName = SLIT("hiding")
-qualifiedName = SLIT("qualified")
forallName = SLIT("forall")
exportName = SLIT("export")
labelName = SLIT("label")
dynamicName = SLIT("dynamic")
unsafeName = SLIT("unsafe")
-as_var_RDR = mkSrcUnqual varName asName
-hiding_var_RDR = mkSrcUnqual varName hidingName
-qualified_var_RDR = mkSrcUnqual varName qualifiedName
forall_var_RDR = mkSrcUnqual varName forallName
export_var_RDR = mkSrcUnqual varName exportName
label_var_RDR = mkSrcUnqual varName labelName
dynamic_var_RDR = mkSrcUnqual varName dynamicName
unsafe_var_RDR = mkSrcUnqual varName unsafeName
-as_tyvar_RDR = mkSrcUnqual tvName asName
-hiding_tyvar_RDR = mkSrcUnqual tvName hidingName
-qualified_tyvar_RDR = mkSrcUnqual tvName qualifiedName
export_tyvar_RDR = mkSrcUnqual tvName exportName
label_tyvar_RDR = mkSrcUnqual tvName labelName
dynamic_tyvar_RDR = mkSrcUnqual tvName dynamicName
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 475534f139a9..f97ff966dbff 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.7 1999/06/25 14:38:54 simonmar Exp $
+$Id: Parser.y,v 1.8 1999/06/28 15:42:33 simonmar Exp $
Haskell grammar.
@@ -61,7 +61,6 @@ Conflicts: 14 shift/reduce
%token
'_' { ITunderscore } -- Haskell keywords
- 'as' { ITas }
'case' { ITcase }
'class' { ITclass }
'data' { ITdata }
@@ -69,7 +68,6 @@ Conflicts: 14 shift/reduce
'deriving' { ITderiving }
'do' { ITdo }
'else' { ITelse }
- 'hiding' { IThiding }
'if' { ITif }
'import' { ITimport }
'in' { ITin }
@@ -81,7 +79,6 @@ Conflicts: 14 shift/reduce
'module' { ITmodule }
'newtype' { ITnewtype }
'of' { ITof }
- 'qualified' { ITqualified }
'then' { ITthen }
'type' { ITtype }
'where' { ITwhere }
@@ -860,9 +857,6 @@ qvarid :: { RdrName }
varid :: { RdrName }
: VARID { mkSrcUnqual varName $1 }
- | 'as' { as_var_RDR }
- | 'qualified' { qualified_var_RDR }
- | 'hiding' { hiding_var_RDR }
| 'forall' { forall_var_RDR }
| 'export' { export_var_RDR }
| 'label' { label_var_RDR }
@@ -871,14 +865,16 @@ varid :: { RdrName }
varid_no_unsafe :: { RdrName }
: VARID { mkSrcUnqual varName $1 }
- | 'as' { as_var_RDR }
- | 'qualified' { qualified_var_RDR }
- | 'hiding' { hiding_var_RDR }
| 'forall' { forall_var_RDR }
| 'export' { export_var_RDR }
| 'label' { label_var_RDR }
| 'dynamic' { dynamic_var_RDR }
+-- ``special'' Ids
+'as' :: { () } : VARID {% checkAs $1 }
+'qualified' :: { () } : VARID {% checkQualified $1 }
+'hiding' :: { () } : VARID {% checkHiding $1 }
+
-----------------------------------------------------------------------------
-- ConIds
@@ -970,9 +966,6 @@ qtycls :: { RdrName }
tyvar :: { RdrName }
: VARID { mkSrcUnqual tvName $1 }
- | 'as' { as_tyvar_RDR }
- | 'qualified' { qualified_tyvar_RDR }
- | 'hiding' { hiding_tyvar_RDR }
| 'export' { export_var_RDR }
| 'label' { label_var_RDR }
| 'dynamic' { dynamic_var_RDR }
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 5d58b407a6e1..419fa119470c 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -69,9 +69,6 @@ import Ratio ( (%) )
'then' { ITthen }
'type' { ITtype }
'where' { ITwhere }
- 'as' { ITas }
- 'qualified' { ITqualified }
- 'hiding' { IThiding }
'forall' { ITforall } -- GHC extension keywords
'foreign' { ITforeign }
@@ -459,9 +456,6 @@ var_fs :: { EncodedFS }
: VARID { $1 }
| VARSYM { $1 }
| '!' { SLIT("!") }
- | 'as' { SLIT("as") }
- | 'qualified' { SLIT("qualified") }
- | 'hiding' { SLIT("hiding") }
| 'forall' { SLIT("forall") }
| 'foreign' { SLIT("foreign") }
| 'export' { SLIT("export") }
--
GitLab