projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Avoid making Either String an instance of Monad in the Haddock parser
[ghc-hetmet.git]
/
compiler
/
parser
/
Lexer.x
diff --git
a/compiler/parser/Lexer.x
b/compiler/parser/Lexer.x
index
8b637da
..
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
@@
-405,7
+417,6
@@
data Token
| ITdata
| ITdefault
| ITderiving
| ITdata
| ITdefault
| ITderiving
- | ITderive
| ITdo
| ITelse
| IThiding
| ITdo
| ITelse
| IThiding
@@
-548,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
@@
-559,7
+571,6
@@
isSpecial :: Token -> Bool
-- not as a keyword.
isSpecial ITas = True
isSpecial IThiding = True
-- not as a keyword.
isSpecial ITas = True
isSpecial IThiding = True
-isSpecial ITderive = True
isSpecial ITqualified = True
isSpecial ITforall = True
isSpecial ITexport = True
isSpecial ITqualified = True
isSpecial ITforall = True
isSpecial ITexport = True
@@
-590,7
+601,6
@@
reservedWordsFM = listToUFM $
( "data", ITdata, 0 ),
( "default", ITdefault, 0 ),
( "deriving", ITderiving, 0 ),
( "data", ITdata, 0 ),
( "default", ITdefault, 0 ),
( "deriving", ITderiving, 0 ),
- ( "derive", ITderive, 0 ),
( "do", ITdo, 0 ),
( "else", ITelse, 0 ),
( "hiding", IThiding, 0 ),
( "do", ITdo, 0 ),
( "else", ITelse, 0 ),
( "hiding", IThiding, 0 ),
@@
-774,7
+784,7
@@
multiline_doc_comment span buf _len = withLexedDocType (worker "")
nested_comment :: P (Located Token) -> Action
nested_comment cont span _str _len = do
input <- getInput
nested_comment :: P (Located Token) -> Action
nested_comment cont span _str _len = do
input <- getInput
- go 1 input
+ go (1::Int) input
where
go 0 input = do setInput input; cont
go n input = case alexGetChar input of
where
go 0 input = do setInput input; cont
go n input = case alexGetChar input of
@@
-814,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
@@
-1301,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
-- -----------------------------------------------------------------------------
@@
-1584,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