improve panic messages a bit, with the GHC version and platform

[ghc-hetmet.git] / ghc / compiler / parser / Lexer.x

diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x
index 90fbf7a..31acaa0 100644 (file)
--- a/ghc/compiler/parser/Lexer.x
+++ b/ghc/compiler/parser/Lexer.x
@@ -22,7 +22,7 @@
 
 {
 module Lexer (
-   Token(..), lexer, mkPState, PState(..),
+   Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc, 
    failLocMsgP, failSpanMsgP, srcParseFail,
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
@@ -47,6 +47,12 @@ import DATA_BITS
 import Data.Char
 import Ratio
 --import TRACE
+
+#if __GLASGOW_HASKELL__ >= 605
+import Data.Char       ( GeneralCategory(..), generalCategory )
+#else
+import Compat.Unicode  ( GeneralCategory(..), generalCategory )
+#endif
 }
 
 $unispace    = \x05
@@ -152,7 +158,7 @@ $white_no_nl+                               ;
 -- generate a matching '}' token.
 <layout_left>  ()                      { do_layout_left }
 
-<0,glaexts> \n                         { begin bol }
+<0,option_prags,glaexts> \n                            { begin bol }
 
 "{-#" $whitechar* (line|LINE)          { begin line_prag2 }
 
@@ -178,7 +184,7 @@ $white_no_nl+                               ;
 <glaexts>
   "{-#" $whitechar* (RULES|rules)      { token ITrules_prag }
 
-<0,glaexts> {
+<0,option_prags,glaexts> {
   "{-#" $whitechar* (INLINE|inline)    { token (ITinline_prag True) }
   "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
                                        { token (ITinline_prag False) }
@@ -195,13 +201,20 @@ $white_no_nl+                             ;
   "{-#" $whitechar* (SCC|scc)          { token ITscc_prag }
   "{-#" $whitechar* (CORE|core)                { token ITcore_prag }
   "{-#" $whitechar* (UNPACK|unpack)    { token ITunpack_prag }
-  
+
   "{-#"                                { nested_comment }
 
   -- ToDo: should only be valid inside a pragma:
   "#-}"                                { token ITclose_prag}
 }
 
+<option_prags> {
+  "{-#" $whitechar* (OPTIONS|options)   { lex_string_prag IToptions_prag }
+  "{-#" $whitechar* (OPTIONS_GHC|options_ghc)
+                                        { lex_string_prag IToptions_prag }
+  "{-#" $whitechar* (LANGUAGE|language) { token ITlanguage_prag }
+  "{-#" $whitechar* (INCLUDE|include)   { lex_string_prag ITinclude_prag }
+}
 
 -- '0' state: ordinary lexemes
 -- 'glaexts' state: glasgow extensions (postfix '#', etc.)
@@ -242,7 +255,7 @@ $white_no_nl+                               ;
   "|}"                                 { token ITccurlybar }
 }
 
-<0,glaexts> {
+<0,option_prags,glaexts> {
   \(                                   { special IToparen }
   \)                                   { special ITcparen }
   \[                                   { special ITobrack }
@@ -255,7 +268,7 @@ $white_no_nl+                               ;
   \}                                   { close_brace }
 }
 
-<0,glaexts> {
+<0,option_prags,glaexts> {
   @qual @varid                 { check_qvarid }
   @qual @conid                 { idtoken qconid }
   @varid                       { varid }
@@ -371,6 +384,9 @@ data Token
   | ITcore_prag                 -- hdaume: core annotations
   | ITunpack_prag
   | ITclose_prag
+  | IToptions_prag String
+  | ITinclude_prag String
+  | ITlanguage_prag
 
   | ITdotdot                   -- reserved symbols
   | ITcolon
@@ -845,6 +861,32 @@ setFile code span buf len = do
   pushLexState code
   lexToken
 
+
+-- -----------------------------------------------------------------------------
+-- Options, includes and language pragmas.
+
+lex_string_prag :: (String -> Token) -> Action
+lex_string_prag mkTok span buf len
+    = do input <- getInput
+         start <- getSrcLoc
+         tok <- go [] input
+         end <- getSrcLoc
+         return (L (mkSrcSpan start end) tok)
+    where go acc input
+              = if isString input "#-}"
+                   then do setInput input
+                           return (mkTok (reverse acc))
+                   else case alexGetChar input of
+                          Just (c,i) -> go (c:acc) i
+                          Nothing -> err input
+          isString i [] = True
+          isString i (x:xs)
+              = case alexGetChar i of
+                  Just (c,i') | c == x    -> isString i' xs
+                  _other -> False
+          err (AI end _ _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
+
+
 -- -----------------------------------------------------------------------------
 -- Strings & Chars
 
@@ -1182,9 +1224,6 @@ alexGetChar (AI loc ofs s)
        other_graphic   = '\x6'
 
        adj_c 
-#if __GLASGOW_HASKELL__ < 605
-         = c  -- no Unicode support
-#else
          | c <= '\x06' = non_graphic
          | c <= '\xff' = c
          | otherwise = 
@@ -1213,7 +1252,6 @@ alexGetChar (AI loc ofs s)
                  OtherSymbol           -> symbol
                  Space                 -> space
                  _other                -> non_graphic
-#endif
 
 -- This version does not squash unicode characters, it is used when
 -- lexing strings.
@@ -1271,6 +1309,22 @@ ipEnabled      flags = testBit flags ipBit
 tvEnabled      flags = testBit flags tvBit
 bangPatEnabled flags = testBit flags bangPatBit
 
+-- PState for parsing options pragmas
+--
+pragState :: StringBuffer -> SrcLoc -> PState
+pragState buf loc  = 
+  PState {
+      buffer    = buf,
+      last_loc   = mkSrcSpan loc loc,
+      last_offs  = 0,
+      last_len   = 0,
+      loc        = loc,
+      extsBitmap = 0,
+      context    = [],
+      lex_state  = [bol, option_prags, 0]
+    }
+
+
 -- create a parse state
 --
 mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState