X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FLexer.x;h=90fbf7a8c23cd5aab750aa0fa1f99d66a5e57fa9;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=38908a0a8562cf756a1b1f9ea61017dc5c0f27a9;hpb=9d7da331989abcd1844e9d03b8d1e4163796fa85;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x
index 38908a0..90fbf7a 100644
--- a/ghc/compiler/parser/Lexer.x
+++ b/ghc/compiler/parser/Lexer.x
@@ -26,7 +26,8 @@ module Lexer (
    P(..), ParseResult(..), getSrcLoc, 
    failLocMsgP, failSpanMsgP, srcParseFail,
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
-   getLexState, popLexState, pushLexState
+   getLexState, popLexState, pushLexState,
+   extension, bangPatEnabled
   ) where
 
 #include "HsVersions.h"
@@ -559,10 +560,13 @@ reservedSymsFM = listToUFM $
        ,(">>-",	ITRarrowtail,	bit arrowsBit)
 
 #if __GLASGOW_HASKELL__ >= 605
-       ,("∀",	ITforall,	bit tvBit)
-       ,("→",   ITrarrow,	0)
-       ,("←",   ITlarrow,	0)
-       ,("⋯", 	ITdotdot,	0)
+       ,("λ",	ITlam,          bit glaExtsBit)
+       ,("∷",   ITdcolon,       bit glaExtsBit)
+       ,("⇒",   ITdarrow,	bit glaExtsBit)
+       ,("∀",	ITforall,	bit glaExtsBit)
+       ,("→",   ITrarrow,	bit glaExtsBit)
+       ,("←",   ITlarrow,	bit glaExtsBit)
+       ,("⋯", 	ITdotdot,	bit glaExtsBit)
 #endif
        ]
 
@@ -1181,7 +1185,7 @@ alexGetChar (AI loc ofs s)
 #if __GLASGOW_HASKELL__ < 605
 	  = c  -- no Unicode support
 #else
-	  | c <= '\x04' = non_graphic
+	  | c <= '\x06' = non_graphic
 	  | c <= '\xff' = c
 	  | otherwise = 
 		case generalCategory c of
@@ -1254,6 +1258,8 @@ arrowsBit  = 4
 thBit	   = 5
 ipBit      = 6
 tvBit	   = 7	-- Scoped type variables enables 'forall' keyword
+bangPatBit = 8	-- Tells the parser to understand bang-patterns
+		-- (doesn't affect the lexer)
 
 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
 glaExtsEnabled flags = testBit flags glaExtsBit
@@ -1263,6 +1269,7 @@ arrowsEnabled  flags = testBit flags arrowsBit
 thEnabled      flags = testBit flags thBit
 ipEnabled      flags = testBit flags ipBit
 tvEnabled      flags = testBit flags tvBit
+bangPatEnabled flags = testBit flags bangPatBit
 
 -- create a parse state
 --
@@ -1287,6 +1294,7 @@ mkPState buf loc flags  =
 	       .|. thBit      `setBitIf` dopt Opt_TH          flags
 	       .|. ipBit      `setBitIf` dopt Opt_ImplicitParams flags
 	       .|. tvBit      `setBitIf` dopt Opt_ScopedTypeVariables flags
+	       .|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
@@ -1348,7 +1356,7 @@ lexError :: String -> P a
 lexError str = do
   loc <- getSrcLoc
   i@(AI end _ buf) <- getInput
-  reportLexError loc end buf False str
+  reportLexError loc end buf str
 
 -- -----------------------------------------------------------------------------
 -- This is the top-level function: called from the parser each time a
@@ -1370,7 +1378,7 @@ lexToken = do
 		  setLastToken span 0
 		  return (L span ITeof)
     AlexError (AI loc2 _ buf) -> do 
-	reportLexError loc1 loc2 buf True "lexical error"
+	reportLexError loc1 loc2 buf "lexical error"
     AlexSkip inp2 _ -> do
 	setInput inp2
 	lexToken
@@ -1381,10 +1389,13 @@ lexToken = do
 	span `seq` setLastToken span bytes
 	t span buf bytes
 
-reportLexError loc1 loc2 buf is_prev str = 
+-- ToDo: Alex reports the buffer at the start of the erroneous lexeme,
+-- but it would be more informative to report the location where the
+-- error was actually discovered, especially if this is a decoding
+-- error.
+reportLexError loc1 loc2 buf str = 
   let 
-	c | is_prev   = prevChar buf '\0'
-	  | otherwise = fst (nextChar buf)
+	c = fst (nextChar buf)
   in
   if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
     then failLocMsgP loc2 loc2 "UTF-8 decoding error"