projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
FIX BUILD (with GHC 6.2.x): update .hi-boot file
[ghc-hetmet.git]
/
compiler
/
parser
/
Lexer.x
diff --git
a/compiler/parser/Lexer.x
b/compiler/parser/Lexer.x
index
8ae3cd9
..
2f6b732
100644
(file)
--- a/
compiler/parser/Lexer.x
+++ b/
compiler/parser/Lexer.x
@@
-21,6
+21,13
@@
-- - pragma-end should be only valid in a pragma
{
-- - 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,
module Lexer (
Token(..), lexer, pragState, mkPState, PState(..),
P(..), ParseResult(..), getSrcLoc,
@@
-28,7
+35,8
@@
module Lexer (
getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
getLexState, popLexState, pushLexState,
getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
getLexState, popLexState, pushLexState,
- extension, standaloneDerivingEnabled, bangPatEnabled
+ extension, standaloneDerivingEnabled, bangPatEnabled,
+ addWarning
) where
#include "HsVersions.h"
) 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.
-- 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
"--" [^$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* (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:
"{-#" { nested_comment lexToken }
-- ToDo: should only be valid inside a pragma:
@@
-259,11
+264,18
@@
$tab+ { warn Opt_WarnTabs (text "Tab character") }
}
<option_prags> {
}
<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 }
{ 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> {
}
<0,option_prags> {
@@
-276,8
+288,8
@@
$tab+ { warn Opt_WarnTabs (text "Tab character") }
-- Haddock comments
<0> {
-- 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
}
-- "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)
| 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
#ifdef DEBUG
deriving Show -- debugging
@@
-811,7
+824,8
@@
withLexedDocType lexDocComment = do
'|' -> lexDocComment input ITdocCommentNext False
'^' -> lexDocComment input ITdocCommentPrev False
'$' -> lexDocComment input ITdocCommentNamed False
'|' -> 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
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
-- 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
-- -----------------------------------------------------------------------------
lexToken
-- -----------------------------------------------------------------------------
@@
-1581,10
+1595,11
@@
mkPState buf loc flags =
b `setBitIf` cond | cond = bit b
| otherwise = 0
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} ->
= 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
in POk s{messages=(ws', es)} ()
getMessages :: PState -> Messages