[project @ 1999-06-28 15:42:33 by simonmar]

[ghc-hetmet.git] / ghc / compiler / parser / Lex.lhs

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 18a2549..727039c 100644 (file)
--- 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,14 +260,12 @@ haskellKeywordsFM = listToUFM $
        ( "module",     ITmodule ),   
        ( "newtype",    ITnewtype ),  
        ( "of",         ITof ),       
-       ( "qualified",  ITqualified ),
        ( "then",       ITthen ),     
        ( "type",       ITtype ),     
        ( "where",      ITwhere ),
        ( "_scc_",      ITscc )
      ]
 
-
 ghcExtensionKeywordsFM = listToUFM $
        map (\ (x,y) -> (_PK_ x,y))
      [ ( "forall",     ITforall ),
@@ -342,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}
 
 -----------------------------------------------------------------------------
@@ -526,9 +523,8 @@ lexToken cont glaexts buf =
                (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
                _ -> lexError "too many '}'s" buf s
 
-    '#'# | flag glaexts 
-        -> case lookAhead# buf 1# of
-               ')'# -> cont ITcubxparen (setCurrentPos# buf 2#)
+    '#'# -> case lookAhead# buf 1# of
+               ')'#  | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#)
                '-'# -> case lookAhead# buf 2# of
                           '}'# -> cont ITclose_prag (setCurrentPos# buf 3#)
                           _    -> lex_sym cont (incLexeme buf)
@@ -606,7 +602,7 @@ flag _  = True
 lex_prag cont buf
   = case expandWhile# is_space buf of { buf1 ->
     case expandWhile# is_ident (stepOverLexeme buf1) of { buf2 -> 
-    let lexeme = lexemeToFastString buf2 in
+    let lexeme = mkFastString (map toUpper (lexemeToString buf2)) in
     case lookupUFM pragmaKeywordsFM lexeme of
        Just kw -> cont kw (mergeLexemes buf buf2)
        Nothing -> panic "lex_prag"
@@ -982,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   =
@@ -1000,15 +997,11 @@ lex_id3 cont glaexts mod buf just_a_conid
      let
       lexeme  = lexemeToFastString buf'
       new_buf = mergeLexemes buf buf'
+      is_a_qvarid = cont (mk_qvar_token mod lexeme) new_buf
      in
      case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
            Just kwd_token -> just_a_conid; -- avoid M.where etc.
-           Nothing        -> 
-     if flag glaexts
-       then case lookupUFM ghcExtensionKeywordsFM lexeme of {
-           Just kwd_token -> just_a_conid;
-           Nothing        -> cont (mk_qvar_token mod lexeme) new_buf }
-       else just_a_conid
+           Nothing        -> is_a_qvarid
      }}}