Token(..), lexer, pragState, mkPState, PState(..),
P(..), ParseResult(..), getSrcLoc,
failLocMsgP, failSpanMsgP, srcParseFail,
+ getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
getLexState, popLexState, pushLexState,
extension, glaExtsEnabled, bangPatEnabled
#include "HsVersions.h"
-import ErrUtils ( Message )
+import Bag
+import ErrUtils
import Outputable
import StringBuffer
import FastString
import Ctype
import Util ( maybePrefixMatch, readRational )
-import DATA_BITS
+import Control.Monad
+import Data.Bits
import Data.Char ( chr, isSpace )
-import Ratio
-import TRACE
+import Data.Ratio
+import Debug.Trace
#if __GLASGOW_HASKELL__ >= 605
import Data.Char ( GeneralCategory(..), generalCategory, isPrint, isUpper )
#endif
}
-$unispace = \x05
-$whitechar = [\ \t\n\r\f\v\xa0 $unispace]
+$unispace = \x05 -- Trick Alex into handling Unicode. See alexGetChar.
+$whitechar = [\ \n\r\f\v\xa0 $unispace]
$white_no_nl = $whitechar # \n
+$tab = \t
$ascdigit = 0-9
-$unidigit = \x03
+$unidigit = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
$decdigit = $ascdigit -- for now, should really be $digit (ToDo)
$digit = [$ascdigit $unidigit]
$special = [\(\)\,\;\[\]\`\{\}]
$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~ \xa1-\xbf \xd7 \xf7]
-$unisymbol = \x04
+$unisymbol = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
-$unilarge = \x01
+$unilarge = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
$asclarge = [A-Z \xc0-\xd6 \xd8-\xde]
$large = [$asclarge $unilarge]
-$unismall = \x02
+$unismall = \x02 -- Trick Alex into handling Unicode. See alexGetChar.
$ascsmall = [a-z \xdf-\xf6 \xf8-\xff]
$small = [$ascsmall $unismall \_]
-$unigraphic = \x06
+$unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar.
$graphic = [$small $large $symbol $digit $special $unigraphic \:\"\']
$octit = 0-7
@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
$white_no_nl+ ;
+$tab+ { warn Opt_WarnTabs (text "Tab character") }
-- Everywhere: deal with nested comments. We explicitly rule out
-- pragmas, "{-#", so that we don't accidentally treat them as comments.
"{-#" $whitechar* (DEPRECATED|deprecated)
{ token ITdeprecated_prag }
"{-#" $whitechar* (SCC|scc) { token ITscc_prag }
+ "{-#" $whitechar* (GENERATED|generated)
+ { token ITgenerated_prag }
"{-#" $whitechar* (CORE|core) { token ITcore_prag }
"{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag }
-- Haddock comments
<0,glaexts> {
- "-- " / $docsym { multiline_doc_comment }
- "{-" \ ? / $docsym { nested_doc_comment }
+ "-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment }
+ "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
}
-- "special" symbols
@qual @conid { pop_and (idtoken qconid) }
}
-<glaexts> {
- @qual @varid "#"+ { idtoken qvarid }
- @qual @conid "#"+ { idtoken qconid }
- @varid "#"+ { varid }
- @conid "#"+ { idtoken conid }
+<0,glaexts> {
+ @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid }
+ @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid }
+ @varid "#"+ / { ifExtension magicHashEnabled } { varid }
+ @conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid }
}
-- ToDo: M.(,,,)
@consym { consym }
}
+-- For the normal boxed literals we need to be careful
+-- when trying to be close to Haskell98
<0,glaexts> {
- @decimal { tok_decimal }
- 0[oO] @octal { tok_octal }
- 0[xX] @hexadecimal { tok_hexadecimal }
+ -- 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 }
+
+ -- Normal rational literals (:: Fractional a => a, from Rational)
+ @floating_point { strtoken tok_float }
}
<glaexts> {
- @decimal \# { prim_decimal }
- 0[oO] @octal \# { prim_octal }
- 0[xX] @hexadecimal \# { prim_hexadecimal }
+ -- Unboxed ints (:: Int#)
+ -- It's simpler (and faster?) to give separate cases to the negatives,
+ -- especially considering octal/hexadecimal prefixes.
+ @decimal \# { tok_primint positive 0 1 decimal }
+ 0[oO] @octal \# { tok_primint positive 2 3 octal }
+ 0[xX] @hexadecimal \# { tok_primint positive 2 3 hexadecimal }
+ @negative @decimal \# { tok_primint negative 1 2 decimal }
+ @negative 0[oO] @octal \# { tok_primint negative 3 4 octal }
+ @negative 0[xX] @hexadecimal \# { tok_primint negative 3 4 hexadecimal }
+
+ -- Unboxed floats and doubles (:: Float#, :: Double#)
+ -- prim_{float,double} work with signed literals
+ @signed @floating_point \# { init_strtoken 1 tok_primfloat }
+ @signed @floating_point \# \# { init_strtoken 2 tok_primdouble }
}
-<0,glaexts> @floating_point { strtoken tok_float }
-<glaexts> @floating_point \# { init_strtoken 1 prim_float }
-<glaexts> @floating_point \# \# { init_strtoken 2 prim_double }
-
-- 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
}
{
--- work around bug in Alex 2.0
-#if __GLASGOW_HASKELL__ < 503
-unsafeAt arr i = arr ! i
-#endif
-
-- -----------------------------------------------------------------------------
-- The token type
| ITdata
| ITdefault
| ITderiving
+ | ITderive
| ITdo
| ITelse
- | ITfor
| IThiding
| ITif
| ITimport
| ITccallconv
| ITdotnet
| ITmdo
- | ITiso
| ITfamily
-- Pragmas
| ITdeprecated_prag
| ITline_prag
| ITscc_prag
+ | ITgenerated_prag
| ITcore_prag -- hdaume: core annotations
| ITunpack_prag
| ITclose_prag
-- not as a keyword.
isSpecial ITas = True
isSpecial IThiding = True
-isSpecial ITfor = True
+isSpecial ITderive = True
isSpecial ITqualified = True
isSpecial ITforall = True
isSpecial ITexport = True
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
isSpecial ITmdo = True
-isSpecial ITiso = True
isSpecial ITfamily = True
isSpecial _ = False
( "data", ITdata, 0 ),
( "default", ITdefault, 0 ),
( "deriving", ITderiving, 0 ),
+ ( "derive", ITderive, 0 ),
( "do", ITdo, 0 ),
( "else", ITelse, 0 ),
- ( "for", ITfor, 0 ),
( "hiding", IThiding, 0 ),
( "if", ITif, 0 ),
( "import", ITimport, 0 ),
( "_scc_", ITscc, 0 ), -- ToDo: remove
( "forall", ITforall, bit tvBit),
- ( "mdo", ITmdo, bit glaExtsBit),
- ( "family", ITfamily, bit idxTysBit),
+ ( "mdo", ITmdo, bit recursiveDoBit),
+ ( "family", ITfamily, bit tyFamBit),
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
,("-", ITminus, 0)
,("!", ITbang, 0)
- ,("*", ITstar, bit glaExtsBit .|.
- bit idxTysBit) -- For data T (a::*) = MkT
+ ,("*", ITstar, bit glaExtsBit .|. bit kindSigsBit .|.
+ bit tyFamBit) -- For data T (a::*) = MkT
,(".", ITdot, bit tvBit) -- For 'forall a . t'
,("-<", ITlarrowtail, bit arrowsBit)
,(">>-", ITRarrowtail, bit arrowsBit)
#if __GLASGOW_HASKELL__ >= 605
- ,("λ", ITlam, bit glaExtsBit)
,("∷", ITdcolon, bit glaExtsBit)
,("⇒", ITdarrow, bit glaExtsBit)
,("∀", ITforall, bit glaExtsBit)
pop_and :: Action -> Action
pop_and act span buf len = do popLexState; act span buf len
-notFollowedBy char _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf /= char
+{-# INLINE nextCharIs #-}
+nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
+
+notFollowedBy char _ _ _ (AI _ _ buf)
+ = nextCharIs buf (/=char)
notFollowedBySymbol _ _ _ (AI _ _ buf)
- = atEnd buf || currentChar buf `notElem` "!#$%&*+./<=>?@\\^|-~"
+ = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
+-- We must reject doc comments as being ordinary comments everywhere.
+-- In some cases the doc comment will be selected as the lexeme due to
+-- maximal munch, but not always, because the nested comment rule is
+-- valid in all states, but the doc-comment rules are only valid in
+-- the non-layout states.
isNormalComment bits _ _ (AI _ _ buf)
- = (if haddockEnabled bits then False else (followedBySpaceDoc buf))
- || notFollowedByDocOrPragma
- where
- notFollowedByDocOrPragma = not $ spaceAndP buf
- (\buf' -> currentChar buf' `elem` "|^*$#")
-
-spaceAndP buf p = p buf || currentChar buf == ' ' && p buf'
- where buf' = snd (nextChar buf)
-
-followedBySpaceDoc buf = spaceAndP buf followedByDoc
+ | haddockEnabled bits = notFollowedByDocOrPragma
+ | otherwise = nextCharIs buf (/='#')
+ where
+ notFollowedByDocOrPragma
+ = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
-followedByDoc buf = currentChar buf `elem` "|^*$"
+spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
haddockDisabledAnd p bits _ _ (AI _ _ buf)
= if haddockEnabled bits then False else (p buf)
Just (c,input) -> go (c:commentAcc) input docType False
withLexedDocType lexDocComment = do
- input <- getInput
- case alexGetChar input of
- Nothing -> error "Can't happen"
- Just ('|', input) -> lexDocComment input ITdocCommentNext False
- Just ('^', input) -> lexDocComment input ITdocCommentPrev False
- Just ('$', input) -> lexDocComment input ITdocCommentNamed False
- Just ('*', input) -> lexDocSection 1 input
+ input@(AI _ _ buf) <- getInput
+ case prevChar buf ' ' of
+ '|' -> lexDocComment input ITdocCommentNext False
+ '^' -> lexDocComment input ITdocCommentPrev False
+ '$' -> lexDocComment input ITdocCommentNamed False
+ '*' -> lexDocSection 1 input
where
lexDocSection n input = case alexGetChar input of
Just ('*', input) -> lexDocSection (n+1) input
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 (c,i) -> do setInput i; return c
-- -----------------------------------------------------------------------------
+-- Warnings
+
+warn :: DynFlag -> SDoc -> Action
+warn option warning span _buf _len = do
+ addWarning option (mkWarnMsg span alwaysQualify warning)
+ lexToken
+
+-- -----------------------------------------------------------------------------
-- The Parse Monad
data LayoutContext
data PState = PState {
buffer :: StringBuffer,
+ dflags :: DynFlags,
+ messages :: Messages,
last_loc :: SrcSpan, -- pos of previous token
last_offs :: !Int, -- offset of the previous token from the
-- beginning of the current line.
adj_c
| c <= '\x06' = non_graphic
| c <= '\xff' = 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.
| otherwise =
case generalCategory c of
UppercaseLetter -> upper
tvBit = 7 -- Scoped type variables enables 'forall' keyword
bangPatBit = 8 -- Tells the parser to understand bang-patterns
-- (doesn't affect the lexer)
-idxTysBit = 9 -- indexed type families: 'family' keyword and kind sigs
+tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs
haddockBit = 10 -- Lex and parse Haddock comments
+magicHashBit = 11 -- # in both functions and operators
+kindSigsBit = 12 -- Kind signatures on type variables
+recursiveDoBit = 13 -- mdo
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
-idxTysEnabled flags = testBit flags idxTysBit
-haddockEnabled flags = testBit flags haddockBit
+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
+magicHashEnabled flags = testBit flags magicHashBit
+kindSigsEnabled flags = testBit flags kindSigsBit
+recursiveDoEnabled flags = testBit flags recursiveDoBit
-- PState for parsing options pragmas
--
pragState buf loc =
PState {
buffer = buf,
+ messages = emptyMessages,
+ -- XXX defaultDynFlags is not right, but we don't have a real
+ -- dflags handy
+ dflags = defaultDynFlags,
last_loc = mkSrcSpan loc loc,
last_offs = 0,
last_len = 0,
mkPState buf loc flags =
PState {
buffer = buf,
+ dflags = flags,
+ messages = emptyMessages,
last_loc = mkSrcSpan loc loc,
last_offs = 0,
last_len = 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
- .|. idxTysBit `setBitIf` dopt Opt_IndexedTypes flags
- .|. haddockBit `setBitIf` dopt Opt_Haddock flags
+ 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
+ .|. magicHashBit `setBitIf` dopt Opt_MagicHash flags
+ .|. kindSigsBit `setBitIf` dopt Opt_KindSignatures flags
+ .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
| otherwise = 0
+addWarning :: DynFlag -> WarnMsg -> P ()
+addWarning option w
+ = P $ \s@PState{messages=(ws,es), dflags=d} ->
+ let ws' = if dopt option d then ws `snocBag` w else ws
+ in POk s{messages=(ws', es)} ()
+
+getMessages :: PState -> Messages
+getMessages PState{messages=ms} = ms
+
getContext :: P [LayoutContext]
getContext = P $ \s@PState{context=ctx} -> POk s ctx
projects / ghc-hetmet.git / blobdiff