getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
getLexState, popLexState, pushLexState,
- extension, glaExtsEnabled, bangPatEnabled
+ extension, standaloneDerivingEnabled, bangPatEnabled,
+ addWarning
) where
#include "HsVersions.h"
@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
+-- normal signed numerical literals can only be explicitly negative,
+-- not explicitly positive (contrast @exponent)
+@negative = \-
+@signed = @negative ?
+
haskell :-
-- everywhere: skip whitespace and comments
-- generate a matching '}' token.
<layout_left> () { do_layout_left }
-<0,option_prags,glaexts> \n { begin bol }
+<0,option_prags> \n { begin bol }
"{-#" $whitechar* (line|LINE) { begin line_prag2 }
-- NOTE: accept -} at the end of a LINE pragma, for compatibility
-- with older versions of GHC which generated these.
--- We only want RULES pragmas to be picked up when -fglasgow-exts
--- is on, because the contents of the pragma is always written using
--- glasgow-exts syntax (using forall etc.), so if glasgow exts are not
--- enabled, we're sure to get a parse error.
+-- We only want RULES pragmas to be picked up when explicit forall
+-- syntax is enabled is on, because the contents of the pragma always
+-- uses it. If it's not on then we're sure to get a parse error.
-- (ToDo: we should really emit a warning when ignoring pragmas)
-<glaexts>
- "{-#" $whitechar* (RULES|rules) { token ITrules_prag }
+-- XXX Now that we can enable this without the -fglasgow-exts hammer,
+-- is it better just to let the parse error happen?
+<0>
+ "{-#" $whitechar* (RULES|rules) / { ifExtension explicitForallEnabled } { token ITrules_prag }
-<0,option_prags,glaexts> {
+<0,option_prags> {
"{-#" $whitechar* (INLINE|inline) { token (ITinline_prag True) }
"{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
{ token (ITinline_prag False) }
"{-#" $whitechar* (INCLUDE|include) { lex_string_prag ITinclude_prag }
}
-<0,option_prags,glaexts> {
+<0,option_prags> {
-- This is to catch things like {-# OPTIONS OPTIONS_HUGS ...
"{-#" $whitechar* $idchar+ { nested_comment lexToken }
}
-- '0' state: ordinary lexemes
--- 'glaexts' state: glasgow extensions (postfix '#', etc.)
-- Haddock comments
-<0,glaexts> {
+<0> {
"-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment }
"{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
}
-- "special" symbols
-<0,glaexts> {
+<0> {
"[:" / { ifExtension parrEnabled } { token ITopabrack }
":]" / { ifExtension parrEnabled } { token ITcpabrack }
}
-<0,glaexts> {
+<0> {
"[|" / { ifExtension thEnabled } { token ITopenExpQuote }
"[e|" / { ifExtension thEnabled } { token ITopenExpQuote }
"[p|" / { ifExtension thEnabled } { token ITopenPatQuote }
"$(" / { ifExtension thEnabled } { token ITparenEscape }
}
-<0,glaexts> {
+<0> {
"(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol }
{ special IToparenbar }
"|)" / { ifExtension arrowsEnabled } { special ITcparenbar }
}
-<0,glaexts> {
+<0> {
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
}
-<glaexts> {
- "(#" / { notFollowedBySymbol } { token IToubxparen }
- "#)" { token ITcubxparen }
- "{|" { token ITocurlybar }
- "|}" { token ITccurlybar }
+<0> {
+ "(#" / { ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol }
+ { token IToubxparen }
+ "#)" / { ifExtension unboxedTuplesEnabled }
+ { token ITcubxparen }
+}
+
+<0> {
+ "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
+ "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
}
-<0,option_prags,glaexts> {
+<0,option_prags> {
\( { special IToparen }
\) { special ITcparen }
\[ { special ITobrack }
\} { close_brace }
}
-<0,option_prags,glaexts> {
- @qual @varid { check_qvarid }
+<0,option_prags> {
+ @qual @varid { idtoken qvarid }
@qual @conid { idtoken qconid }
@varid { varid }
@conid { idtoken conid }
}
--- after an illegal qvarid, such as 'M.let',
--- we back up and try again in the bad_qvarid state:
-<bad_qvarid> {
- @conid { pop_and (idtoken conid) }
- @qual @conid { pop_and (idtoken qconid) }
-}
-
-<glaexts> {
- @qual @varid "#"+ { idtoken qvarid }
- @qual @conid "#"+ { idtoken qconid }
- @varid "#"+ { varid }
- @conid "#"+ { idtoken conid }
+<0> {
+ @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
+ @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
+ @varid "#"+ / { ifExtension magicHashEnabled } { varid }
+ @conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid }
}
-- ToDo: M.(,,,)
-<0,glaexts> {
+<0> {
@qual @varsym { idtoken qvarsym }
@qual @consym { idtoken qconsym }
@varsym { varsym }
@consym { consym }
}
-<0,glaexts> {
- @decimal { tok_decimal }
- 0[oO] @octal { tok_octal }
- 0[xX] @hexadecimal { tok_hexadecimal }
-}
+-- For the normal boxed literals we need to be careful
+-- 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 }
-<glaexts> {
- @decimal \# { prim_decimal }
- 0[oO] @octal \# { prim_octal }
- 0[xX] @hexadecimal \# { prim_hexadecimal }
+ -- Normal rational literals (:: Fractional a => a, from Rational)
+ @floating_point { strtoken tok_float }
}
-<0,glaexts> @floating_point { strtoken tok_float }
-<glaexts> @floating_point \# { init_strtoken 1 prim_float }
-<glaexts> @floating_point \# \# { init_strtoken 2 prim_double }
+<0> {
+ -- Unboxed ints (:: Int#)
+ -- 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 }
+ @negative 0[xX] @hexadecimal \# / { ifExtension magicHashEnabled } { tok_primint negative 3 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 }
+ @signed @floating_point \# \# / { ifExtension magicHashEnabled } { init_strtoken 2 tok_primdouble }
+}
-- Strings and chars are lexed by hand-written code. The reason is
-- that even if we recognise the string or char here in the regex
-- lexer, we would still have to parse the string afterward in order
-- to convert it to a String.
-<0,glaexts> {
+<0> {
\' { lex_char_tok }
\" { lex_string_tok }
}
| ITdata
| ITdefault
| ITderiving
- | ITderive
| ITdo
| ITelse
| IThiding
-- not as a keyword.
isSpecial ITas = True
isSpecial IThiding = True
-isSpecial ITderive = True
isSpecial ITqualified = True
isSpecial ITforall = True
isSpecial ITexport = True
( "data", ITdata, 0 ),
( "default", ITdefault, 0 ),
( "deriving", ITderiving, 0 ),
- ( "derive", ITderive, 0 ),
( "do", ITdo, 0 ),
( "else", ITelse, 0 ),
( "hiding", IThiding, 0 ),
( "where", ITwhere, 0 ),
( "_scc_", ITscc, 0 ), -- ToDo: remove
- ( "forall", ITforall, bit tvBit),
- ( "mdo", ITmdo, bit glaExtsBit),
+ ( "forall", ITforall, bit explicitForallBit),
+ ( "mdo", ITmdo, bit recursiveDoBit),
( "family", ITfamily, bit tyFamBit),
( "foreign", ITforeign, bit ffiBit),
( "proc", ITproc, bit arrowsBit)
]
+reservedSymsFM :: UniqFM (Token, Int -> Bool)
reservedSymsFM = listToUFM $
- map (\ (x,y,z) -> (mkFastString x,(y,z)))
- [ ("..", ITdotdot, 0)
- ,(":", ITcolon, 0) -- (:) is a reserved op,
- -- meaning only list cons
- ,("::", ITdcolon, 0)
- ,("=", ITequal, 0)
- ,("\\", ITlam, 0)
- ,("|", ITvbar, 0)
- ,("<-", ITlarrow, 0)
- ,("->", ITrarrow, 0)
- ,("@", ITat, 0)
- ,("~", ITtilde, 0)
- ,("=>", ITdarrow, 0)
- ,("-", ITminus, 0)
- ,("!", ITbang, 0)
-
- ,("*", ITstar, bit glaExtsBit .|.
- bit tyFamBit) -- For data T (a::*) = MkT
- ,(".", ITdot, bit tvBit) -- For 'forall a . t'
-
- ,("-<", ITlarrowtail, bit arrowsBit)
- ,(">-", ITrarrowtail, bit arrowsBit)
- ,("-<<", ITLarrowtail, bit arrowsBit)
- ,(">>-", ITRarrowtail, bit arrowsBit)
+ map (\ (x,y,z) -> (mkFastString x,(y,z)))
+ [ ("..", ITdotdot, always)
+ -- (:) is a reserved op, meaning only list cons
+ ,(":", ITcolon, always)
+ ,("::", ITdcolon, always)
+ ,("=", ITequal, always)
+ ,("\\", ITlam, always)
+ ,("|", ITvbar, always)
+ ,("<-", ITlarrow, always)
+ ,("->", ITrarrow, always)
+ ,("@", ITat, always)
+ ,("~", ITtilde, always)
+ ,("=>", ITdarrow, always)
+ ,("-", ITminus, always)
+ ,("!", ITbang, always)
+
+ -- For data T (a::*) = MkT
+ ,("*", ITstar, \i -> kindSigsEnabled i || tyFamEnabled i)
+ -- For 'forall a . t'
+ ,(".", ITdot, explicitForallEnabled)
+
+ ,("-<", ITlarrowtail, arrowsEnabled)
+ ,(">-", ITrarrowtail, arrowsEnabled)
+ ,("-<<", ITLarrowtail, arrowsEnabled)
+ ,(">>-", ITRarrowtail, arrowsEnabled)
#if __GLASGOW_HASKELL__ >= 605
- ,("∷", ITdcolon, bit glaExtsBit)
- ,("⇒", ITdarrow, bit glaExtsBit)
- ,("∀", ITforall, bit glaExtsBit)
- ,("→", ITrarrow, bit glaExtsBit)
- ,("←", ITlarrow, bit glaExtsBit)
- ,("⋯", ITdotdot, bit glaExtsBit)
+ ,("∷", ITdcolon, unicodeSyntaxEnabled)
+ ,("⇒", ITdarrow, unicodeSyntaxEnabled)
+ ,("∀", ITforall, \i -> unicodeSyntaxEnabled i &&
+ explicitForallEnabled i)
+ ,("→", ITrarrow, unicodeSyntaxEnabled)
+ ,("←", ITlarrow, unicodeSyntaxEnabled)
+ ,("⋯", ITdotdot, unicodeSyntaxEnabled)
-- ToDo: ideally, → and ∷ should be "specials", so that they cannot
-- form part of a large operator. This would let us have a better
-- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
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
popContext
return (L span ITccurly)
--- We have to be careful not to count M.<varid> as a qualified name
--- when <varid> is a keyword. We hack around this by catching
--- the offending tokens afterward, and re-lexing in a different state.
-check_qvarid span buf len = do
- case lookupUFM reservedWordsFM var of
- Just (keyword,exts)
- | not (isSpecial keyword) ->
- if exts == 0
- then try_again
- else do
- b <- extension (\i -> exts .&. i /= 0)
- if b then try_again
- else return token
- _other -> return token
- where
- (mod,var) = splitQualName buf len
- token = L span (ITqvarid (mod,var))
-
- try_again = do
- (AI _ offs _) <- getInput
- setInput (AI (srcSpanStart span) (offs-len) buf)
- pushLexState bad_qvarid
- lexToken
-
qvarid buf len = ITqvarid $! splitQualName buf len
qconid buf len = ITqconid $! splitQualName buf len
sym con span buf len =
case lookupUFM reservedSymsFM fs of
- Just (keyword,0) -> return (L span keyword)
Just (keyword,exts) -> do
- b <- extension (\i -> exts .&. i /= 0)
+ b <- extension exts
if b then return (L span keyword)
else return (L span $! con fs)
_other -> return (L span $! con fs)
where
fs = lexemeToFastString buf len
-tok_decimal span buf len
- = return (L span (ITinteger $! parseInteger buf len 10 octDecDigit))
-
-tok_octal span buf len
- = return (L span (ITinteger $! parseInteger (offsetBytes 2 buf) (len-2) 8 octDecDigit))
-
-tok_hexadecimal span buf len
- = return (L span (ITinteger $! parseInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
-
-prim_decimal span buf len
- = return (L span (ITprimint $! parseInteger buf (len-1) 10 octDecDigit))
-
-prim_octal span buf len
- = return (L span (ITprimint $! parseInteger (offsetBytes 2 buf) (len-3) 8 octDecDigit))
-
-prim_hexadecimal span buf len
- = return (L span (ITprimint $! parseInteger (offsetBytes 2 buf) (len-3) 16 hexDigit))
-
+-- Variations on the integral numeric literal.
+tok_integral :: (Integer -> Token)
+ -> (Integer -> Integer)
+ -- -> (StringBuffer -> StringBuffer) -> (Int -> Int)
+ -> Int -> Int
+ -> (Integer, (Char->Int)) -> Action
+tok_integral itint transint transbuf translen (radix,char_to_int) span buf len =
+ return $ L span $ itint $! transint $ parseUnsignedInteger
+ (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
+
+-- some conveniences for use with tok_integral
+tok_num = tok_integral ITinteger
+tok_primint = tok_integral ITprimint
+positive = id
+negative = negate
+decimal = (10,octDecDigit)
+octal = (8,octDecDigit)
+hexadecimal = (16,hexDigit)
+
+-- readRational can understand negative rationals, exponents, everything.
tok_float str = ITrational $! readRational str
-prim_float str = ITprimfloat $! readRational str
-prim_double str = ITprimdouble $! readRational str
+tok_primfloat str = ITprimfloat $! readRational str
+tok_primdouble str = ITprimdouble $! readRational str
-- -----------------------------------------------------------------------------
-- Layout processing
setLine :: Int -> Action
setLine code span buf len = do
- let line = parseInteger buf len 10 octDecDigit
+ let line = parseUnsignedInteger buf len 10 octDecDigit
setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
-- subtract one: the line number refers to the *following* line
popLexState
Just ('"',i) -> do
setInput i
- glaexts <- extension glaExtsEnabled
- if glaexts
+ magicHash <- extension magicHashEnabled
+ if magicHash
then do
i <- getInput
case alexGetChar' i of
finish_char_tok :: SrcLoc -> Char -> P (Located Token)
finish_char_tok loc ch -- We've already seen the closing quote
-- Just need to check for trailing #
- = do glaexts <- extension glaExtsEnabled
+ = do magicHash <- extension magicHashEnabled
i@(AI end _ _) <- getInput
- if glaexts then do
+ if magicHash then do
case alexGetChar' i of
Just ('#',i@(AI end _ _)) -> do
setInput i
-- 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
-- -----------------------------------------------------------------------------
-- -fglasgow-exts or -fparr) are represented by a bitmap stored in an unboxed
-- integer
-glaExtsBit, ffiBit, parrBit :: Int
-glaExtsBit = 0
+genericsBit, ffiBit, parrBit :: Int
+genericsBit = 0 -- {| and |}
ffiBit = 1
parrBit = 2
arrowsBit = 4
thBit = 5
ipBit = 6
-tvBit = 7 -- Scoped type variables enables 'forall' keyword
+explicitForallBit = 7 -- the 'forall' keyword and '.' symbol
bangPatBit = 8 -- Tells the parser to understand bang-patterns
-- (doesn't affect the lexer)
tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs
haddockBit = 10 -- Lex and parse Haddock comments
-
-glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
-glaExtsEnabled flags = testBit flags glaExtsBit
-ffiEnabled flags = testBit flags ffiBit
-parrEnabled flags = testBit flags parrBit
-arrowsEnabled flags = testBit flags arrowsBit
-thEnabled flags = testBit flags thBit
-ipEnabled flags = testBit flags ipBit
-tvEnabled flags = testBit flags tvBit
-bangPatEnabled flags = testBit flags bangPatBit
-tyFamEnabled flags = testBit flags tyFamBit
-haddockEnabled flags = testBit flags haddockBit
+magicHashBit = 11 -- # in both functions and operators
+kindSigsBit = 12 -- Kind signatures on type variables
+recursiveDoBit = 13 -- mdo
+unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc
+unboxedTuplesBit = 15 -- (# and #)
+standaloneDerivingBit = 16 -- standalone instance deriving declarations
+
+genericsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
+always _ = True
+genericsEnabled flags = testBit flags genericsBit
+ffiEnabled flags = testBit flags ffiBit
+parrEnabled flags = testBit flags parrBit
+arrowsEnabled flags = testBit flags arrowsBit
+thEnabled flags = testBit flags thBit
+ipEnabled flags = testBit flags ipBit
+explicitForallEnabled flags = testBit flags explicitForallBit
+bangPatEnabled flags = testBit flags bangPatBit
+tyFamEnabled flags = testBit flags tyFamBit
+haddockEnabled flags = testBit flags haddockBit
+magicHashEnabled flags = testBit flags magicHashBit
+kindSigsEnabled flags = testBit flags kindSigsBit
+recursiveDoEnabled flags = testBit flags recursiveDoBit
+unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit
+unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit
+standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit
-- PState for parsing options pragmas
--
loc = loc,
extsBitmap = fromIntegral bitmap,
context = [],
- lex_state = [bol, if glaExtsEnabled bitmap then glaexts else 0]
+ lex_state = [bol, 0]
-- we begin in the layout state if toplev_layout is set
}
where
- bitmap = glaExtsBit `setBitIf` dopt Opt_GlasgowExts flags
- .|. ffiBit `setBitIf` dopt Opt_FFI flags
- .|. parrBit `setBitIf` dopt Opt_PArr flags
- .|. arrowsBit `setBitIf` dopt Opt_Arrows flags
- .|. thBit `setBitIf` dopt Opt_TH flags
- .|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
- .|. tvBit `setBitIf` dopt Opt_ScopedTypeVariables flags
- .|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
- .|. tyFamBit `setBitIf` dopt Opt_TypeFamilies flags
- .|. haddockBit `setBitIf` dopt Opt_Haddock flags
+ bitmap = genericsBit `setBitIf` dopt Opt_Generics flags
+ .|. ffiBit `setBitIf` dopt Opt_ForeignFunctionInterface flags
+ .|. parrBit `setBitIf` dopt Opt_PArr flags
+ .|. arrowsBit `setBitIf` dopt Opt_Arrows flags
+ .|. thBit `setBitIf` dopt Opt_TemplateHaskell flags
+ .|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
+ .|. explicitForallBit `setBitIf` dopt Opt_ScopedTypeVariables flags
+ .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
+ .|. explicitForallBit `setBitIf` dopt Opt_ExistentialQuantification flags
+ .|. explicitForallBit `setBitIf` dopt Opt_Rank2Types flags
+ .|. explicitForallBit `setBitIf` dopt Opt_RankNTypes flags
+ .|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
+ .|. tyFamBit `setBitIf` dopt Opt_TypeFamilies flags
+ .|. haddockBit `setBitIf` dopt Opt_Haddock flags
+ .|. magicHashBit `setBitIf` dopt Opt_MagicHash flags
+ .|. kindSigsBit `setBitIf` dopt Opt_KindSignatures flags
+ .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
+ .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
+ .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags
+ .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags
--
setBitIf :: Int -> Bool -> Int
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