-- 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.
module Lexer (
Token(..), lexer, pragState, mkPState, PState(..),
addWarning
) where
-#include "HsVersions.h"
-
import Bag
import ErrUtils
import Outputable
import Control.Monad
import Data.Bits
-import Data.Char ( chr, isSpace )
+import Data.Char ( chr, ord, isSpace )
import Data.Ratio
import Debug.Trace
-- 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
-"-- " $docsym .* / { ifExtension (not . haddockEnabled) } ;
+"-- " [$docsym \#] .* / { ifExtension (not . haddockEnabled) } ;
-- Now, when we've matched comments that begin with 2 dashes and continue
-- with a different character, we need to match comments that begin with three
"{-#" $whitechar* (CORE|core) { token ITcore_prag }
"{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag }
- "{-#" $whitechar* (DOC_OPTIONS|doc_options)
- / { ifExtension haddockEnabled } { lex_string_prag ITdocOptions }
-
"{-#" { nested_comment lexToken }
-- ToDo: should only be valid inside a pragma:
}
<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> {
-- 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
"|]" / { ifExtension thEnabled } { token ITcloseQuote }
\$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape }
"$(" / { ifExtension thEnabled } { token ITparenEscape }
+
+ "[$" @varid "|" / { ifExtension qqEnabled }
+ { lex_quasiquote_tok }
}
<0> {
-- 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 }
| ITdotnet
| ITmdo
| ITfamily
+ | ITgroup
+ | ITby
+ | ITusing
-- Pragmas
| ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE
| ITprimchar Char
| ITprimstring FastString
| ITprimint Integer
+ | ITprimword Integer
| ITprimfloat Rational
| ITprimdouble Rational
| ITparenEscape -- $(
| ITvarQuote -- '
| ITtyQuote -- ''
+ | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|]
-- Arrow notation extension
| ITproc
| 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
#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 ITstdcallconv = True
isSpecial ITmdo = True
isSpecial ITfamily = True
+isSpecial ITgroup = True
+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
( "where", ITwhere, 0 ),
( "_scc_", ITscc, 0 ), -- ToDo: remove
- ( "forall", ITforall, bit explicitForallBit),
+ ( "forall", ITforall, bit explicitForallBit),
( "mdo", ITmdo, bit recursiveDoBit),
( "family", ITfamily, bit tyFamBit),
+ ( "group", ITgroup, bit transformComprehensionsBit),
+ ( "by", ITby, bit transformComprehensionsBit),
+ ( "using", ITusing, bit transformComprehensionsBit),
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
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
'|' -> 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
- Just (c, _) -> lexDocComment input (ITdocSection n) True
+ Just (_, _) -> lexDocComment input (ITdocSection n) True
Nothing -> do setInput input; lexToken -- eof reached, lex it normally
-- docCommentEnd
qual_size = orig_buf `byteDiff` dot_buf
varid span buf len =
+ fs `seq`
case lookupUFM reservedWordsFM fs of
Just (keyword,0) -> do
maybe_layout keyword
-- 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 ->
Just (c,i) -> do setInput i; return c
-- -----------------------------------------------------------------------------
+-- QuasiQuote
+
+lex_quasiquote_tok :: Action
+lex_quasiquote_tok span buf len = do
+ let quoter = reverse $ takeWhile (/= '$')
+ $ reverse $ lexemeToString buf (len - 1)
+ quoteStart <- getSrcLoc
+ quote <- lex_quasiquote ""
+ end <- getSrcLoc
+ return (L (mkSrcSpan (srcSpanStart span) end)
+ (ITquasiQuote (mkFastString quoter,
+ mkFastString (reverse quote),
+ mkSrcSpan quoteStart end)))
+
+lex_quasiquote :: String -> P String
+lex_quasiquote s = do
+ i <- getInput
+ case alexGetChar' i of
+ Nothing -> lit_error
+
+ Just ('\\',i)
+ | Just ('|',i) <- next -> do
+ setInput i; lex_quasiquote ('|' : s)
+ | Just (']',i) <- next -> do
+ setInput i; lex_quasiquote (']' : s)
+ where next = alexGetChar' i
+
+ Just ('|',i)
+ | Just (']',i) <- next -> do
+ setInput i; return s
+ where next = alexGetChar' i
+
+ Just (c, i) -> do
+ setInput i; lex_quasiquote (c : s)
+
+-- -----------------------------------------------------------------------------
-- Warnings
warn :: DynFlag -> SDoc -> Action
fail = failP
returnP :: a -> P a
-returnP a = P $ \s -> POk s a
+returnP a = a `seq` (P $ \s -> POk s a)
thenP :: P a -> (a -> P b) -> P b
(P m) `thenP` k = P $ \ s ->
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)
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
unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
unboxedTuplesBit = 15 -- (# and #)
standaloneDerivingBit = 16 -- standalone instance deriving declarations
+transformComprehensionsBit = 17
+qqBit = 18 -- enable quasiquoting
genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
always _ = True
unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
+transformComprehensionsEnabled flags = testBit flags transformComprehensionsBit
+qqEnabled flags = testBit flags qqBit
-- PState for parsing options pragmas
--
.|. parrBit `setBitIf` dopt Opt_PArr flags
.|. arrowsBit `setBitIf` dopt Opt_Arrows flags
.|. thBit `setBitIf` dopt Opt_TemplateHaskell flags
+ .|. qqBit `setBitIf` dopt Opt_QuasiQuotes flags
.|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
.|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
.|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
.|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
.|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
.|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
+ .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
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
sc <- getLexState
exts <- getExts
case alexScanUser exts inp sc of
- AlexEOF -> do let span = mkSrcSpan loc1 loc1
- setLastToken span 0 0
- return (L span ITeof)
- AlexError (AI loc2 _ buf) -> do
- reportLexError loc1 loc2 buf "lexical error"
+ AlexEOF -> do
+ let span = mkSrcSpan loc1 loc1
+ setLastToken span 0 0
+ return (L span ITeof)
+ AlexError (AI loc2 _ buf) ->
+ reportLexError loc1 loc2 buf "lexical error"
AlexSkip inp2 _ -> do
- setInput inp2
- lexToken
- AlexToken inp2@(AI end _ buf2) len t -> do
- setInput inp2
- let span = mkSrcSpan loc1 end
- let bytes = byteDiff buf buf2
- span `seq` setLastToken span bytes bytes
- t span buf bytes
+ setInput inp2
+ lexToken
+ AlexToken inp2@(AI end _ buf2) _ t -> do
+ setInput inp2
+ let span = mkSrcSpan loc1 end
+ let bytes = byteDiff buf buf2
+ span `seq` setLastToken span bytes bytes
+ t span buf bytes
reportLexError loc1 loc2 buf str
| atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
projects / ghc-hetmet.git / blobdiff