-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
+--
+-- Note that Alex itself generates code with with some unused bindings and
+-- without type signatures, so removing the flag might not be possible.
+
+{-# OPTIONS_GHC -funbox-strict-fields #-}
module Lexer (
Token(..), lexer, pragState, mkPState, PState(..),
addWarning
) where
-#include "HsVersions.h"
-
import Bag
import ErrUtils
import Outputable
import Data.Ratio
import Debug.Trace
-#if __GLASGOW_HASKELL__ >= 605
-import Data.Char ( GeneralCategory(..), generalCategory, isPrint, isUpper )
-#else
-import Compat.Unicode ( GeneralCategory(..), generalCategory, isPrint, isUpper )
-#endif
+import Unicode ( GeneralCategory(..), generalCategory, isPrint, isUpper )
}
$unispace = \x05 -- Trick Alex into handling Unicode. See alexGetChar.
-$whitechar = [\ \n\r\f\v\xa0 $unispace]
+$whitechar = [\ \n\r\f\v $unispace]
$white_no_nl = $whitechar # \n
$tab = \t
$digit = [$ascdigit $unidigit]
$special = [\(\)\,\;\[\]\`\{\}]
-$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~ \xa1-\xbf \xd7 \xf7]
+$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
$unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
$unilarge = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
-$asclarge = [A-Z \xc0-\xd6 \xd8-\xde]
+$asclarge = [A-Z]
$large = [$asclarge $unilarge]
$unismall = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
-$ascsmall = [a-z \xdf-\xf6 \xf8-\xff]
+$ascsmall = [a-z]
$small = [$ascsmall $unismall \_]
$unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
$whitechar* (NO(T?)INLINE|no(t?)inline)
{ token (ITspec_inline_prag False) }
"{-#" $whitechar* (SOURCE|source) { token ITsource_prag }
+ "{-#" $whitechar* (WARNING|warning)
+ { token ITwarning_prag }
"{-#" $whitechar* (DEPRECATED|deprecated)
{ token ITdeprecated_prag }
"{-#" $whitechar* (SCC|scc) { token ITscc_prag }
-- when trying to be close to Haskell98
<0> {
-- Normal integral literals (:: Num a => a, from Integer)
- @decimal { tok_num positive 0 0 decimal }
- 0[oO] @octal { tok_num positive 2 2 octal }
- 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal }
+ @decimal { tok_num positive 0 0 decimal }
+ 0[oO] @octal { tok_num positive 2 2 octal }
+ 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal }
-- Normal rational literals (:: Fractional a => a, from Rational)
- @floating_point { strtoken tok_float }
+ @floating_point { strtoken tok_float }
}
<0> {
- -- Unboxed ints (:: Int#)
+ -- Unboxed ints (:: Int#) and words (:: Word#)
-- It's simpler (and faster?) to give separate cases to the negatives,
-- especially considering octal/hexadecimal prefixes.
- @decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
- 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
- 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
- @negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
- @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
+ @decimal \# / { ifExtension magicHashEnabled } { tok_primint positive 0 1 decimal }
+ 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 octal }
+ 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint positive 2 3 hexadecimal }
+ @negative @decimal \# / { ifExtension magicHashEnabled } { tok_primint negative 1 2 decimal }
+ @negative 0[oO] @octal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 octal }
@negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 4 hexadecimal }
+ @decimal \# \# / { ifExtension magicHashEnabled } { tok_primword 0 2 decimal }
+ 0[oO] @octal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 octal }
+ 0[xX] @hexadecimal \# \# / { ifExtension magicHashEnabled } { tok_primword 2 4 hexadecimal }
+
-- Unboxed floats and doubles (:: Float#, :: Double#)
-- prim_{float,double} work with signed literals
@signed @floating_point \# / { ifExtension magicHashEnabled } { init_strtoken 1 tok_primfloat }
| ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE)
| ITsource_prag
| ITrules_prag
+ | ITwarning_prag
| ITdeprecated_prag
| ITline_prag
| ITscc_prag
| ITvocurly
| ITvccurly
| ITobrack
- | ITopabrack -- [:, for parallel arrays with -fparr
- | ITcpabrack -- :], for parallel arrays with -fparr
+ | ITopabrack -- [:, for parallel arrays with -XParr
+ | ITcpabrack -- :], for parallel arrays with -XParr
| ITcbrack
| IToparen
| ITcparen
| ITprimchar Char
| ITprimstring FastString
| ITprimint Integer
+ | ITprimword Integer
| ITprimfloat Rational
| ITprimdouble Rational
deriving Show -- debugging
#endif
+{-
isSpecial :: Token -> Bool
-- If we see M.x, where x is a keyword, but
-- is special, we treat is as just plain M.x,
isSpecial ITby = True
isSpecial ITusing = True
isSpecial _ = False
+-}
-- the bitmap provided as the third component indicates whether the
-- corresponding extension keyword is valid under the extension options
type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
special :: Token -> Action
-special tok span _buf len = return (L span tok)
+special tok span _buf _len = return (L span tok)
token, layout_token :: Token -> Action
-token t span buf len = return (L span t)
-layout_token t span buf len = pushLexState layout >> return (L span t)
+token t span _buf _len = return (L span t)
+layout_token t span _buf _len = pushLexState layout >> return (L span t)
idtoken :: (StringBuffer -> Int -> Token) -> Action
idtoken f span buf len = return (L span $! (f buf len))
spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
+{-
haddockDisabledAnd p bits _ _ (AI _ _ buf)
= if haddockEnabled bits then False else (p buf)
+-}
atEOL _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf == '\n'
Just ('-',input) -> case alexGetChar input of
Nothing -> errBrace input span
Just ('\125',input) -> go (n-1) input
- Just (c,_) -> go n input
+ Just (_,_) -> go n input
Just ('\123',input) -> case alexGetChar input of
Nothing -> errBrace input span
Just ('-',input) -> go (n+1) input
- Just (c,_) -> go n input
- Just (c,input) -> go n input
+ Just (_,_) -> go n input
+ Just (_,input) -> go n input
nested_doc_comment :: Action
nested_doc_comment span buf _len = withLexedDocType (go "")
Nothing -> errBrace input span
Just ('-',input) -> case alexGetChar input of
Nothing -> errBrace input span
- Just ('\125',input@(AI end _ buf2)) ->
+ Just ('\125',input) ->
docCommentEnd input commentAcc docType buf span
- Just (c,_) -> go ('-':commentAcc) input docType False
+ Just (_,_) -> go ('-':commentAcc) input docType False
Just ('\123', input) -> case alexGetChar input of
Nothing -> errBrace input span
Just ('-',input) -> do
setInput input
let cont = do input <- getInput; go commentAcc input docType False
nested_comment cont span buf _len
- Just (c,_) -> go ('\123':commentAcc) input docType False
+ Just (_,_) -> go ('\123':commentAcc) input docType False
Just (c,input) -> go (c:commentAcc) input docType False
withLexedDocType lexDocComment = do
where
lexDocSection n input = case alexGetChar input of
Just ('*', input) -> lexDocSection (n+1) input
- Just (c, _) -> lexDocComment input (ITdocSection n) True
+ Just (_, _) -> lexDocComment input (ITdocSection n) True
Nothing -> do setInput input; lexToken -- eof reached, lex it normally
-- docCommentEnd
-- some conveniences for use with tok_integral
tok_num = tok_integral ITinteger
tok_primint = tok_integral ITprimint
+tok_primword = tok_integral ITprimword positive
positive = id
negative = negate
decimal = (10,octDecDigit)
-- we must generate a {} sequence now.
pushLexState layout_left
return (L span ITvocurly)
- other -> do
+ _ -> do
setContext (Layout offset : ctx)
return (L span ITvocurly)
-- Options, includes and language pragmas.
lex_string_prag :: (String -> Token) -> Action
-lex_string_prag mkTok span buf len
+lex_string_prag mkTok span _buf _len
= do input <- getInput
start <- getSrcLoc
tok <- go [] input
else case alexGetChar input of
Just (c,i) -> go (c:acc) i
Nothing -> err input
- isString i [] = True
+ isString _ [] = True
isString i (x:xs)
= case alexGetChar i of
Just (c,i') | c == x -> isString i' xs
-- This stuff is horrible. I hates it.
lex_string_tok :: Action
-lex_string_tok span buf len = do
+lex_string_tok span _buf _len = do
tok <- lex_string ""
end <- getSrcLoc
return (L (mkSrcSpan (srcSpanStart span) end) tok)
-- but WIHTOUT CONSUMING the x or T part (the parser does that).
-- So we have to do two characters of lookahead: when we see 'x we need to
-- see if there's a trailing quote
-lex_char_tok span buf len = do -- We've seen '
+lex_char_tok span _buf _len = do -- We've seen '
i1 <- getInput -- Look ahead to first character
let loc = srcSpanStart span
case alexGetChar' i1 of
return (L (mkSrcSpan loc end2) ITtyQuote)
else lit_error
- Just ('\\', i2@(AI end2 _ _)) -> do -- We've seen 'backslash
+ Just ('\\', i2@(AI _end2 _ _)) -> do -- We've seen 'backslash
setInput i2
lit_ch <- lex_escape
mc <- getCharOrFail -- Trailing quote
if mc == '\'' then finish_char_tok loc lit_ch
else do setInput i2; lit_error
- Just (c, i2@(AI end2 _ _))
+ Just (c, i2@(AI _end2 _ _))
| not (isAny c) -> lit_error
| otherwise ->
c | isAny c -> do setInput inp; return c
_other -> lit_error
-isAny c | c > '\xff' = isPrint c
+isAny c | c > '\x7f' = isPrint c
| otherwise = is_any c
lex_escape :: P Char
'x' -> readNum is_hexdigit 16 hexDigit
'o' -> readNum is_octdigit 8 octDecDigit
- x | is_digit x -> readNum2 is_digit 10 octDecDigit (octDecDigit x)
+ x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x)
c1 -> do
i <- getInput
failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
-failLocMsgP loc1 loc2 str = P $ \s -> PFailed (mkSrcSpan loc1 loc2) (text str)
+failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
-failSpanMsgP :: SrcSpan -> String -> P a
-failSpanMsgP span msg = P $ \s -> PFailed span (text msg)
+failSpanMsgP :: SrcSpan -> SDoc -> P a
+failSpanMsgP span msg = P $ \_ -> PFailed span msg
extension :: (Int -> Bool) -> P Bool
extension p = P $ \s -> POk s (p $! extsBitmap s)
adj_c
| c <= '\x06' = non_graphic
- | c <= '\xff' = c
+ | c <= '\x7f' = c
-- Alex doesn't handle Unicode, so when Unicode
-- character is encoutered we output these values
-- with the actual character value hidden in the state.
LowercaseLetter -> lower
TitlecaseLetter -> upper
ModifierLetter -> other_graphic
- OtherLetter -> other_graphic
+ OtherLetter -> lower -- see #1103
NonSpacingMark -> other_graphic
SpacingCombiningMark -> other_graphic
EnclosingMark -> other_graphic
ofs' = advanceOffs c ofs
advanceOffs :: Char -> Int -> Int
-advanceOffs '\n' offs = 0
+advanceOffs '\n' _ = 0
advanceOffs '\t' offs = (offs `quot` 8 + 1) * 8
advanceOffs _ offs = offs + 1
popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls
getLexState :: P Int
-getLexState = P $ \s@PState{ lex_state=ls:l } -> POk s ls
+getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
-- for reasons of efficiency, flags indicating language extensions (eg,
--- -fglasgow-exts or -fparr) are represented by a bitmap stored in an unboxed
+-- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed
-- integer
genericsBit, ffiBit, parrBit :: Int
-- PState for parsing options pragmas
--
-pragState :: StringBuffer -> SrcLoc -> PState
-pragState buf loc =
+pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+pragState dynflags buf loc =
PState {
- buffer = buf,
+ buffer = buf,
messages = emptyMessages,
- -- XXX defaultDynFlags is not right, but we don't have a real
- -- dflags handy
- dflags = defaultDynFlags,
+ dflags = dynflags,
last_loc = mkSrcSpan loc loc,
last_offs = 0,
last_len = 0,
popContext :: P ()
popContext = P $ \ s@(PState{ buffer = buf, context = ctx,
- loc = loc, last_len = len, last_loc = last_loc }) ->
+ last_len = len, last_loc = last_loc }) ->
case ctx of
(_:tl) -> POk s{ context = tl } ()
[] -> PFailed last_loc (srcParseErr buf len)
-> Message
srcParseErr buf len
= hcat [ if null token
- then ptext SLIT("parse error (possibly incorrect indentation)")
- else hcat [ptext SLIT("parse error on input "),
+ then ptext (sLit "parse error (possibly incorrect indentation)")
+ else hcat [ptext (sLit "parse error on input "),
char '`', text token, char '\'']
]
where token = lexemeToString (offsetBytes (-len) buf) len
lexError :: String -> P a
lexError str = do
loc <- getSrcLoc
- i@(AI end _ buf) <- getInput
+ (AI end _ buf) <- getInput
reportLexError loc end buf str
-- -----------------------------------------------------------------------------
lexer :: (Located Token -> P a) -> P a
lexer cont = do
- tok@(L span tok__) <- lexToken
+ tok@(L _span _tok__) <- lexToken
-- trace ("token: " ++ show tok__) $ do
cont tok
AlexSkip inp2 _ -> do
setInput inp2
lexToken
- AlexToken inp2@(AI end _ buf2) len t -> do
+ AlexToken inp2@(AI end _ buf2) _ t -> do
setInput inp2
let span = mkSrcSpan loc1 end
let bytes = byteDiff buf buf2
projects / ghc-hetmet.git / blobdiff