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 Control.Monad
import Data.Bits
import Data.Char ( chr, isSpace )
import Data.Ratio
#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
-- 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.
-- 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
}
{
--- work around bug in Alex 2.0
-#if __GLASGOW_HASKELL__ < 503
-unsafeAt arr i = arr ! i
-#endif
-
-- -----------------------------------------------------------------------------
-- The token type
| ITccallconv
| ITdotnet
| ITmdo
- | ITiso
| ITfamily
-- Pragmas
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
isSpecial ITmdo = True
-isSpecial ITiso = True
isSpecial ITfamily = True
isSpecial _ = False
( "forall", ITforall, bit tvBit),
( "mdo", ITmdo, bit glaExtsBit),
- ( "family", ITfamily, bit idxTysBit),
+ ( "family", ITfamily, bit tyFamBit),
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
,("!", ITbang, 0)
,("*", ITstar, bit glaExtsBit .|.
- bit idxTysBit) -- For data T (a::*) = MkT
+ 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)
notFollowedBySymbol _ _ _ (AI _ _ buf)
= 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)
| haddockEnabled bits = notFollowedByDocOrPragma
| otherwise = nextCharIs buf (/='#')
- where
- notFollowedByDocOrPragma
- = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
+ where
+ notFollowedByDocOrPragma
+ = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar 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
fs = lexemeToFastString buf len
tok_decimal span buf len
- = return (L span (ITinteger $! parseInteger buf len 10 octDecDigit))
+ = return (L span (ITinteger $! parseUnsignedInteger buf len 10 octDecDigit))
tok_octal span buf len
- = return (L span (ITinteger $! parseInteger (offsetBytes 2 buf) (len-2) 8 octDecDigit))
+ = return (L span (ITinteger $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 8 octDecDigit))
tok_hexadecimal span buf len
- = return (L span (ITinteger $! parseInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
+ = return (L span (ITinteger $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
prim_decimal span buf len
- = return (L span (ITprimint $! parseInteger buf (len-1) 10 octDecDigit))
+ = return (L span (ITprimint $! parseUnsignedInteger buf (len-1) 10 octDecDigit))
prim_octal span buf len
- = return (L span (ITprimint $! parseInteger (offsetBytes 2 buf) (len-3) 8 octDecDigit))
+ = return (L span (ITprimint $! parseUnsignedInteger (offsetBytes 2 buf) (len-3) 8 octDecDigit))
prim_hexadecimal span buf len
- = return (L span (ITprimint $! parseInteger (offsetBytes 2 buf) (len-3) 16 hexDigit))
+ = return (L span (ITprimint $! parseUnsignedInteger (offsetBytes 2 buf) (len-3) 16 hexDigit))
tok_float str = ITrational $! readRational str
prim_float str = ITprimfloat $! readRational str
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
glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
ipEnabled flags = testBit flags ipBit
tvEnabled flags = testBit flags tvBit
bangPatEnabled flags = testBit flags bangPatBit
-idxTysEnabled flags = testBit flags idxTysBit
+tyFamEnabled flags = testBit flags tyFamBit
haddockEnabled flags = testBit flags haddockBit
-- 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
+ 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
+ .|. tyFamBit `setBitIf` dopt Opt_TypeFamilies flags
+ .|. haddockBit `setBitIf` dopt Opt_Haddock 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