X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=2f6b7329a9a54b75f7ffe80577df418e2973ced5;hb=cf375afbaa55bc6cae521eff5b26ff04c27b452e;hp=8ae3cd94353621ab1ccdc0495380dfa14ba77d92;hpb=914e7d90e2afe1f72b72fb41d293fb56bd35edb5;p=ghc-hetmet.git

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 8ae3cd9..2f6b732 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -21,6 +21,13 @@
 --    - pragma-end should be only valid in a pragma
 
 {
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module Lexer (
    Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc, 
@@ -28,7 +35,8 @@ module Lexer (
    getMessages,
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
    getLexState, popLexState, pushLexState,
-   extension, standaloneDerivingEnabled, bangPatEnabled
+   extension, standaloneDerivingEnabled, bangPatEnabled,
+   addWarning
   ) where
 
 #include "HsVersions.h"
@@ -141,7 +149,7 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 -- space followed by a Haddock comment symbol (docsym) (in which case we'd
 -- have a Haddock comment). The rules then munch the rest of the line.
 
-"-- " ~$docsym .* ;
+"-- " ~[$docsym \#] .* ;
 "--" [^$symbol : \ ] .* ;
 
 -- Next, match Haddock comments if no -haddock flag
@@ -249,9 +257,6 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
   "{-#" $whitechar* (CORE|core)		{ token ITcore_prag }
   "{-#" $whitechar* (UNPACK|unpack)	{ token ITunpack_prag }
 
-  "{-#" $whitechar* (DOCOPTIONS|docoptions)
-  / { ifExtension haddockEnabled }     { lex_string_prag ITdocOptions }
-
  "{-#"                                 { nested_comment lexToken }
 
   -- ToDo: should only be valid inside a pragma:
@@ -259,11 +264,18 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 }
 
 <option_prags> {
-  "{-#" $whitechar* (OPTIONS|options)   { lex_string_prag IToptions_prag }
-  "{-#" $whitechar* (OPTIONS_GHC|options_ghc)
+  "{-#"  $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 }
+  "{-#"  $whitechar* (OPTIONS_HADDOCK|options_haddock)
+                                         { lex_string_prag ITdocOptions }
+  "-- #"                                 { multiline_doc_comment }
+  "{-#"  $whitechar* (LANGUAGE|language) { token ITlanguage_prag }
+  "{-#"  $whitechar* (INCLUDE|include)   { lex_string_prag ITinclude_prag }
+}
+
+<0> {
+  "-- #" .* ;
 }
 
 <0,option_prags> {
@@ -276,8 +288,8 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 -- Haddock comments
 
 <0> {
-  "-- " $docsym    / { ifExtension haddockEnabled } { multiline_doc_comment }
-  "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
+  "-- " $docsym      / { ifExtension haddockEnabled } { multiline_doc_comment }
+  "{-" \ ? $docsym   / { ifExtension haddockEnabled } { nested_doc_comment }
 }
 
 -- "special" symbols
@@ -547,6 +559,7 @@ data Token
   | ITdocCommentNamed String     -- something beginning '-- $'
   | ITdocSection      Int String -- a section heading
   | ITdocOptions      String     -- doc options (prune, ignore-exports, etc)
+  | ITdocOptionsOld   String     -- doc options declared "-- # ..."-style
 
 #ifdef DEBUG
   deriving Show -- debugging
@@ -811,7 +824,8 @@ withLexedDocType lexDocComment = do
     '|' -> lexDocComment input ITdocCommentNext False
     '^' -> lexDocComment input ITdocCommentPrev False
     '$' -> lexDocComment input ITdocCommentNamed False
-    '*' -> lexDocSection 1 input 
+    '*' -> lexDocSection 1 input
+    '#' -> lexDocComment input ITdocOptionsOld False
  where 
     lexDocSection n input = case alexGetChar input of 
       Just ('*', input) -> lexDocSection (n+1) input
@@ -1298,8 +1312,8 @@ getCharOrFail =  do
 -- Warnings
 
 warn :: DynFlag -> SDoc -> Action
-warn option warning span _buf _len = do
-    addWarning option (mkWarnMsg span alwaysQualify warning)
+warn option warning srcspan _buf _len = do
+    addWarning option srcspan warning
     lexToken
 
 -- -----------------------------------------------------------------------------
@@ -1581,10 +1595,11 @@ mkPState buf loc flags  =
       b `setBitIf` cond | cond      = bit b
 			| otherwise = 0
 
-addWarning :: DynFlag -> WarnMsg -> P ()
-addWarning option w
+addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
+addWarning option srcspan warning
  = P $ \s@PState{messages=(ws,es), dflags=d} ->
-       let ws' = if dopt option d then ws `snocBag` w else ws
+       let warning' = mkWarnMsg srcspan alwaysQualify warning
+           ws' = if dopt option d then ws `snocBag` warning' else ws
        in POk s{messages=(ws', es)} ()
 
 getMessages :: PState -> Messages