X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=96660128386e20adcb50a37006fb8aa47704f7e2;hp=a4a343985a3ee64c216c74e519f1c111e9d92076;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=e9f9ec1e57d53b9302a395ce0d02c0fa59e28341 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index a4a3439..9666012 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -7,7 +7,8 @@ -- definition, with some hand-coded bits. -- -- Completely accurate information about token-spans within the source --- file is maintained. Every token has a start and end SrcLoc attached to it. +-- file is maintained. Every token has a start and end RealSrcLoc +-- attached to it. -- ----------------------------------------------------------------------------- @@ -32,6 +33,7 @@ { -- XXX The above flags turn off warnings in the generated code: +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} @@ -50,9 +52,11 @@ module Lexer ( failLocMsgP, failSpanMsgP, srcParseFail, getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, getLexState, popLexState, pushLexState, - extension, standaloneDerivingEnabled, bangPatEnabled, + extension, bangPatEnabled, datatypeContextsEnabled, addWarning, + incrBracketDepth, incrBracketDepth1, decrBracketDepth, getParserBrakDepth, pushBracketDepth, popBracketDepth, lexTokenStream ) where @@ -66,7 +70,9 @@ import UniqFM import DynFlags import Module import Ctype +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) import Util ( readRational ) +import HsSyn (CodeFlavor(..)) import Control.Monad import Data.Bits @@ -139,7 +145,7 @@ haskell :- -- everywhere: skip whitespace and comments $white_no_nl+ ; -$tab+ { warn Opt_WarnTabs (text "Tab character") } +$tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- Everywhere: deal with nested comments. We explicitly rule out -- pragmas, "{-#", so that we don't accidentally treat them as comments. @@ -209,7 +215,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- context if the curly brace is missing. -- Careful! This stuff is quite delicate. { - \{ / { notFollowedBy '-' } { pop_and open_brace } + \{ / { notFollowedBy '-' } { hopefully_open_brace } -- we might encounter {-# here, but {- has been handled already \n ; ^\# (line)? { begin line_prag1 } @@ -285,7 +291,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- Haddock comments -<0> { +<0,option_prags> { "-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment } "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment } } @@ -307,6 +313,10 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } "$(" / { ifExtension thEnabled } { token ITparenEscape } +-- For backward compatibility, accept the old dollar syntax + "[$" @varid "|" / { ifExtension qqEnabled } + { lex_quasiquote_tok } + "[" @varid "|" / { ifExtension qqEnabled } { lex_quasiquote_tok } } @@ -318,6 +328,18 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } } <0> { + "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol } + { special ITopenBrak } + "]>" / { ifExtension hetMetEnabled } { special ITcloseBrak } + "<{" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol } + { special ITopenBrak1 } + "}>" / { ifExtension hetMetEnabled } { special ITcloseBrak1 } + "~~" / { ifExtension hetMetEnabled } { special ITescape } + "%%" / { ifExtension hetMetEnabled } { special ITdoublePercent } + "~~$" / { ifExtension hetMetEnabled } { special ITescapeDollar } +} + +<0> { \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } } @@ -328,11 +350,6 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } { token ITcubxparen } } -<0> { - "{|" / { ifExtension genericsEnabled } { token ITocurlybar } - "|}" / { ifExtension genericsEnabled } { token ITccurlybar } -} - <0,option_prags> { \( { special IToparen } \) { special ITcparen } @@ -363,10 +380,8 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- ToDo: - move `var` and (sym) into lexical syntax? -- - remove backquote from $special? <0> { - @qual @varsym / { ifExtension oldQualOps } { idtoken qvarsym } - @qual @consym / { ifExtension oldQualOps } { idtoken qconsym } - @qual \( @varsym \) / { ifExtension newQualOps } { idtoken prefixqvarsym } - @qual \( @consym \) / { ifExtension newQualOps } { idtoken prefixqconsym } + @qual @varsym { idtoken qvarsym } + @qual @consym { idtoken qconsym } @varsym { varsym } @consym { consym } } @@ -451,6 +466,7 @@ data Token | ITdynamic | ITsafe | ITthreadsafe + | ITinterruptible | ITunsafe | ITstdcallconv | ITccallconv @@ -462,8 +478,7 @@ data Token | ITusing -- Pragmas - | ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE - | ITinline_conlike_prag Bool -- same + | ITinline_prag InlineSpec RuleMatchInfo | ITspec_prag -- SPECIALISE | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) | ITsource_prag @@ -480,6 +495,9 @@ data Token | IToptions_prag String | ITinclude_prag String | ITlanguage_prag + | ITvect_prag + | ITvect_scalar_prag + | ITnovect_prag | ITdotdot -- reserved symbols | ITcolon @@ -489,6 +507,7 @@ data Token | ITvbar | ITlarrow | ITrarrow + | ITkappa | ITat | ITtilde | ITdarrow @@ -506,8 +525,8 @@ data Token | ITvocurly | ITvccurly | ITobrack - | ITopabrack -- [:, for parallel arrays with -XParr - | ITcpabrack -- :], for parallel arrays with -XParr + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays | ITcbrack | IToparen | ITcparen @@ -534,14 +553,14 @@ data Token | ITchar Char | ITstring FastString | ITinteger Integer - | ITrational Rational + | ITrational FractionalLit | ITprimchar Char | ITprimstring FastString | ITprimint Integer | ITprimword Integer - | ITprimfloat Rational - | ITprimdouble Rational + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit -- Template Haskell extension tokens | ITopenExpQuote -- [| or [e| @@ -553,7 +572,7 @@ data Token | ITparenEscape -- $( | ITvarQuote -- ' | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|] + | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] -- Arrow notation extension | ITproc @@ -565,6 +584,15 @@ data Token | ITLarrowtail -- -<< | ITRarrowtail -- >>- + -- Heterogeneous Metaprogramming extension + | ITopenBrak -- <[ + | ITcloseBrak -- ]> + | ITopenBrak1 -- <{ + | ITcloseBrak1 -- }> + | ITescape -- ~~ + | ITescapeDollar -- ~~$ + | ITdoublePercent -- %% + | ITunknown String -- Used when the lexer can't make sense of it | ITeof -- end of file token @@ -596,6 +624,7 @@ isSpecial ITlabel = True isSpecial ITdynamic = True isSpecial ITsafe = True isSpecial ITthreadsafe = True +isSpecial ITinterruptible = True isSpecial ITunsafe = True isSpecial ITccallconv = True isSpecial ITstdcallconv = True @@ -658,6 +687,7 @@ reservedWordsFM = listToUFM $ ( "dynamic", ITdynamic, bit ffiBit), ( "safe", ITsafe, bit ffiBit), ( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove + ( "interruptible", ITinterruptible, bit ffiBit), ( "unsafe", ITunsafe, bit ffiBit), ( "stdcall", ITstdcallconv, bit ffiBit), ( "ccall", ITccallconv, bit ffiBit), @@ -679,6 +709,7 @@ reservedSymsFM = listToUFM $ ,("|", ITvbar, always) ,("<-", ITlarrow, always) ,("->", ITrarrow, always) + ,("~~>", ITkappa, always) ,("@", ITat, always) ,("~", ITtilde, always) ,("=>", ITdarrow, always) @@ -701,7 +732,6 @@ reservedSymsFM = listToUFM $ explicitForallEnabled i) ,("→", ITrarrow, unicodeSyntaxEnabled) ,("←", ITlarrow, unicodeSyntaxEnabled) - ,("⋯", ITdotdot, unicodeSyntaxEnabled) ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) @@ -718,7 +748,7 @@ reservedSymsFM = listToUFM $ -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token) +type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) special :: Token -> Action special tok span _buf _len = return (L span tok) @@ -750,6 +780,19 @@ pop :: Action pop _span _buf _len = do _ <- popLexState lexToken +hopefully_open_brace :: Action +hopefully_open_brace span buf len + = do relaxed <- extension relaxedLayout + ctx <- getContext + (AI l _) <- getInput + let offset = srcLocCol l + isOK = relaxed || + case ctx of + Layout prev_off : _ -> prev_off < offset + _ -> True + if isOK then pop_and open_brace span buf len + else failSpanMsgP (RealSrcSpan span) (text "Missing block") + pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState act span buf len @@ -830,7 +873,7 @@ lineCommentToken span buf len = do nested comments require traversing by hand, they can't be parsed using regular expressions. -} -nested_comment :: P (Located Token) -> Action +nested_comment :: P (RealLocated Token) -> Action nested_comment cont span _str _len = do input <- getInput go "" (1::Int) input @@ -871,8 +914,8 @@ nested_doc_comment span buf _len = withLexedDocType (go "") Just (_,_) -> go ('\123':commentAcc) input docType False Just (c,input) -> go (c:commentAcc) input docType False -withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token)) - -> P (Located Token) +withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) + -> P (RealLocated Token) withLexedDocType lexDocComment = do input@(AI _ buf) <- getInput case prevChar buf ' ' of @@ -909,19 +952,19 @@ endPrag span _buf _len = do -- called afterwards, so it can just update the state. docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> - SrcSpan -> P (Located Token) + RealSrcSpan -> P (RealLocated Token) docCommentEnd input commentAcc docType buf span = do setInput input let (AI loc nextBuf) = input comment = reverse commentAcc - span' = mkSrcSpan (srcSpanStart span) loc + span' = mkRealSrcSpan (realSrcSpanStart span) loc last_len = byteDiff buf nextBuf span `seq` setLastToken span' last_len return (L span' (docType comment)) -errBrace :: AlexInput -> SrcSpan -> P a -errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'" +errBrace :: AlexInput -> RealSrcSpan -> P a +errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" open_brace, close_brace :: Action open_brace span _str _len = do @@ -996,8 +1039,8 @@ varsym, consym :: Action varsym = sym ITvarsym consym = sym ITconsym -sym :: (FastString -> Token) -> SrcSpan -> StringBuffer -> Int - -> P (Located Token) +sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int + -> P (RealLocated Token) sym con span buf len = case lookupUFM reservedSymsFM fs of Just (keyword,exts) -> do @@ -1040,9 +1083,12 @@ hexadecimal = (16,hexDigit) -- readRational can understand negative rationals, exponents, everything. tok_float, tok_primfloat, tok_primdouble :: String -> Token -tok_float str = ITrational $! readRational str -tok_primfloat str = ITprimfloat $! readRational str -tok_primdouble str = ITprimdouble $! readRational str +tok_float str = ITrational $! readFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str + +readFractionalLit :: String -> FractionalLit +readFractionalLit str = (FL $! str) $! readRational str -- ----------------------------------------------------------------------------- -- Layout processing @@ -1100,10 +1146,12 @@ new_layout_context strict span _buf _len = do (AI l _) <- getInput let offset = srcLocCol l ctx <- getContext + nondecreasing <- extension nondecreasingIndentation + let strict' = strict || not nondecreasing case ctx of Layout prev_off : _ | - (strict && prev_off >= offset || - not strict && prev_off > offset) -> do + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do -- token is indented to the left of the previous context. -- we must generate a {} sequence now. pushLexState layout_left @@ -1124,7 +1172,7 @@ do_layout_left span _buf _len = do setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) -- subtract one: the line number refers to the *following* line _ <- popLexState pushLexState code @@ -1133,12 +1181,17 @@ setLine code span buf len = do setFile :: Int -> Action setFile code span buf len = do let file = lexemeToFastString (stepOn buf) (len-2) - setAlrLastLoc noSrcSpan - setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + setAlrLastLoc $ alrInitialLoc file + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) _ <- popLexState pushLexState code lexToken +alrInitialLoc :: FastString -> RealSrcSpan +alrInitialLoc file = mkRealSrcSpan loc loc + where -- This is a hack to ensure that the first line in a file + -- looks like it is after the initial location: + loc = mkRealSrcLoc file (-1) (-1) -- ----------------------------------------------------------------------------- -- Options, includes and language pragmas. @@ -1149,7 +1202,7 @@ lex_string_prag mkTok span _buf _len start <- getSrcLoc tok <- go [] input end <- getSrcLoc - return (L (mkSrcSpan start end) tok) + return (L (mkRealSrcSpan start end) tok) where go acc input = if isString input "#-}" then do setInput input @@ -1162,7 +1215,7 @@ lex_string_prag mkTok span _buf _len = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False - err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma" + err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" -- ----------------------------------------------------------------------------- @@ -1174,7 +1227,7 @@ lex_string_tok :: Action lex_string_tok span _buf _len = do tok <- lex_string "" end <- getSrcLoc - return (L (mkSrcSpan (srcSpanStart span) end) tok) + return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok) lex_string :: String -> P Token lex_string s = do @@ -1235,7 +1288,7 @@ lex_char_tok :: Action -- see if there's a trailing quote lex_char_tok span _buf _len = do -- We've seen ' i1 <- getInput -- Look ahead to first character - let loc = srcSpanStart span + let loc = realSrcSpanStart span case alexGetChar' i1 of Nothing -> lit_error i1 @@ -1243,7 +1296,7 @@ lex_char_tok span _buf _len = do -- We've seen ' th_exts <- extension thEnabled if th_exts then do setInput i2 - return (L (mkSrcSpan loc end2) ITtyQuote) + return (L (mkRealSrcSpan loc end2) ITtyQuote) else lit_error i1 Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash @@ -1269,10 +1322,10 @@ lex_char_tok span _buf _len = do -- We've seen ' -- If TH is on, just parse the quote only th_exts <- extension thEnabled let (AI end _) = i1 - if th_exts then return (L (mkSrcSpan loc end) ITvarQuote) + if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote) else lit_error i2 -finish_char_tok :: SrcLoc -> Char -> P (Located Token) +finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token) finish_char_tok loc ch -- We've already seen the closing quote -- Just need to check for trailing # = do magicHash <- extension magicHashEnabled @@ -1281,11 +1334,11 @@ finish_char_tok loc ch -- We've already seen the closing quote case alexGetChar' i of Just ('#',i@(AI end _)) -> do setInput i - return (L (mkSrcSpan loc end) (ITprimchar ch)) + return (L (mkRealSrcSpan loc end) (ITprimchar ch)) _other -> - return (L (mkSrcSpan loc end) (ITchar ch)) + return (L (mkRealSrcSpan loc end) (ITchar ch)) else do - return (L (mkSrcSpan loc end) (ITchar ch)) + return (L (mkRealSrcSpan loc end) (ITchar ch)) isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c @@ -1350,11 +1403,13 @@ readNum2 is_digit base conv i = do where read i input = do case alexGetChar' input of Just (c,input') | is_digit c -> do - read (i*base + conv c) input' + let i' = i*base + conv c + if i' > 0x10ffff + then setInput input >> lexError "numeric escape sequence out of range" + else read i' input' _other -> do - if i >= 0 && i <= 0x10FFFF - then do setInput input; return (chr i) - else lit_error input + setInput input; return (chr i) + silly_escape_chars :: [(String, Char)] silly_escape_chars = [ @@ -1418,10 +1473,10 @@ lex_quasiquote_tok span buf len = do quoteStart <- getSrcLoc quote <- lex_quasiquote "" end <- getSrcLoc - return (L (mkSrcSpan (srcSpanStart span) end) + return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITquasiQuote (mkFastString quoter, mkFastString (reverse quote), - mkSrcSpan quoteStart end))) + mkRealSrcSpan quoteStart end))) lex_quasiquote :: String -> P String lex_quasiquote s = do @@ -1449,12 +1504,12 @@ lex_quasiquote s = do warn :: DynFlag -> SDoc -> Action warn option warning srcspan _buf _len = do - addWarning option srcspan warning + addWarning option (RealSrcSpan srcspan) warning lexToken warnThen :: DynFlag -> SDoc -> Action -> Action warnThen option warning action srcspan buf len = do - addWarning option srcspan warning + addWarning option (RealSrcSpan srcspan) warning action srcspan buf len -- ----------------------------------------------------------------------------- @@ -1477,22 +1532,22 @@ data PState = PState { buffer :: StringBuffer, dflags :: DynFlags, messages :: Messages, - last_loc :: SrcSpan, -- pos of previous token + last_loc :: RealSrcSpan, -- pos of previous token last_len :: !Int, -- len of previous token - loc :: SrcLoc, -- current loc (end of prev token + 1) + loc :: RealSrcLoc, -- current loc (end of prev token + 1) extsBitmap :: !Int, -- bitmap that determines permitted extensions context :: [LayoutContext], lex_state :: [Int], -- Used in the alternative layout rule: -- These tokens are the next ones to be sent out. They are -- just blindly emitted, without the rule looking at them again: - alr_pending_implicit_tokens :: [Located Token], + alr_pending_implicit_tokens :: [RealLocated Token], -- This is the next token to be considered or, if it is Nothing, -- we need to get the next token from the input stream: - alr_next_token :: Maybe (Located Token), + alr_next_token :: Maybe (RealLocated Token), -- This is what we consider to be the locatino of the last token -- emitted: - alr_last_loc :: SrcSpan, + alr_last_loc :: RealSrcSpan, -- The stack of layout contexts: alr_context :: [ALRContext], -- Are we expecting a '{'? If it's Just, then the ALRLayout tells @@ -1500,7 +1555,9 @@ data PState = PState { alr_expecting_ocurly :: Maybe ALRLayout, -- Have we just had the '}' for a let block? If so, than an 'in' -- token doesn't need to close anything: - alr_justClosedExplicitLetBlock :: Bool + alr_justClosedExplicitLetBlock :: Bool, + code_type_bracket_depth :: [CodeFlavor], + code_type_bracket_depth_stack :: [CodeFlavor] } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the @@ -1533,13 +1590,13 @@ thenP :: P a -> (a -> P b) -> P b PFailed span err -> PFailed span err failP :: String -> P a -failP msg = P $ \s -> PFailed (last_loc s) (text msg) +failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) failMsgP :: String -> P a -failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg) +failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) -failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a -failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str) +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a +failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) failSpanMsgP :: SrcSpan -> SDoc -> P a failSpanMsgP span msg = P $ \_ -> PFailed span msg @@ -1564,19 +1621,36 @@ getExts = P $ \s -> POk s (extsBitmap s) setExts :: (Int -> Int) -> P () setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () -setSrcLoc :: SrcLoc -> P () +setSrcLoc :: RealSrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () -getSrcLoc :: P SrcLoc +incrBracketDepth :: P () +incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = KappaFlavor:(code_type_bracket_depth s)}) () +incrBracketDepth1 :: P () +incrBracketDepth1 = P $ \s -> POk (s{code_type_bracket_depth = LambdaFlavor:(code_type_bracket_depth s)}) () +decrBracketDepth :: P () +decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = tail (code_type_bracket_depth s)}) () +pushBracketDepth :: P () +pushBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = tail (code_type_bracket_depth s), + code_type_bracket_depth_stack = (head (code_type_bracket_depth s)):(code_type_bracket_depth_stack s) + }) () +popBracketDepth :: P () +popBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (head (code_type_bracket_depth_stack s)):(code_type_bracket_depth s), + code_type_bracket_depth_stack = tail (code_type_bracket_depth_stack s) + }) () +getParserBrakDepth :: P [CodeFlavor] +getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s) + +getSrcLoc :: P RealSrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc -setLastToken :: SrcSpan -> Int -> P () +setLastToken :: RealSrcSpan -> Int -> P () setLastToken loc len = P $ \s -> POk s { last_loc=loc, last_len=len } () -data AlexInput = AI SrcLoc StringBuffer +data AlexInput = AI RealSrcLoc StringBuffer alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (AI _ buf) = prevChar buf '\n' @@ -1616,7 +1690,7 @@ alexGetChar (AI loc s) EnclosingMark -> other_graphic DecimalNumber -> digit LetterNumber -> other_graphic - OtherNumber -> other_graphic + OtherNumber -> digit -- see #4373 ConnectorPunctuation -> symbol DashPunctuation -> symbol OpenPunctuation -> other_graphic @@ -1648,6 +1722,11 @@ getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) setInput :: AlexInput -> P () setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () +nextIsEOF :: P Bool +nextIsEOF = do + AI _ s <- getInput + return $ atEnd s + pushLexState :: Int -> P () pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () @@ -1657,15 +1736,24 @@ popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls getLexState :: P Int getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls -popNextToken :: P (Maybe (Located Token)) +popNextToken :: P (Maybe (RealLocated Token)) popNextToken = P $ \s@PState{ alr_next_token = m } -> POk (s {alr_next_token = Nothing}) m -setAlrLastLoc :: SrcSpan -> P () +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + +setAlrLastLoc :: RealSrcSpan -> P () setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () -getAlrLastLoc :: P SrcSpan +getAlrLastLoc :: P RealSrcSpan getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l getALRContext :: P [ALRContext] @@ -1682,17 +1770,24 @@ setJustClosedExplicitLetBlock :: Bool -> P () setJustClosedExplicitLetBlock b = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () -setNextToken :: Located Token -> P () +setNextToken :: RealLocated Token -> P () setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () -popPendingImplicitToken :: P (Maybe (Located Token)) +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + +popPendingImplicitToken :: P (Maybe (RealLocated Token)) popPendingImplicitToken = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> case ts of [] -> POk s Nothing (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) -setPendingImplicitTokens :: [Located Token] -> P () +setPendingImplicitTokens :: [RealLocated Token] -> P () setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () getAlrExpectingOCurly :: P (Maybe ALRLayout) @@ -1702,11 +1797,13 @@ setAlrExpectingOCurly :: Maybe ALRLayout -> P () setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- for reasons of efficiency, flags indicating language extensions (eg, --- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed +-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed -- integer -genericsBit :: Int -genericsBit = 0 -- {| and |} +-- The "genericsBit" is now unused, available for others +-- genericsBit :: Int +-- genericsBit = 0 -- {|, |} and "generic" + ffiBit :: Int ffiBit = 1 parrBit :: Int @@ -1736,8 +1833,8 @@ unicodeSyntaxBit :: Int unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc unboxedTuplesBit :: Int unboxedTuplesBit = 15 -- (# and #) -standaloneDerivingBit :: Int -standaloneDerivingBit = 16 -- standalone instance deriving declarations +datatypeContextsBit :: Int +datatypeContextsBit = 16 transformComprehensionsBit :: Int transformComprehensionsBit = 17 qqBit :: Int @@ -1746,21 +1843,25 @@ inRulePragBit :: Int inRulePragBit = 19 rawTokenStreamBit :: Int rawTokenStreamBit = 20 -- producing a token stream with all comments included -newQualOpsBit :: Int -newQualOpsBit = 21 -- Haskell' qualified operator syntax, e.g. Prelude.(+) recBit :: Int recBit = 22 -- rec alternativeLayoutRuleBit :: Int alternativeLayoutRuleBit = 23 +relaxedLayoutBit :: Int +relaxedLayoutBit = 24 +nondecreasingIndentationBit :: Int +nondecreasingIndentationBit = 25 +hetMetBit :: Int +hetMetBit = 31 always :: Int -> Bool always _ = True -genericsEnabled :: Int -> Bool -genericsEnabled flags = testBit flags genericsBit parrEnabled :: Int -> Bool parrEnabled flags = testBit flags parrBit arrowsEnabled :: Int -> Bool arrowsEnabled flags = testBit flags arrowsBit +hetMetEnabled :: Int -> Bool +hetMetEnabled flags = testBit flags hetMetBit thEnabled :: Int -> Bool thEnabled flags = testBit flags thBit ipEnabled :: Int -> Bool @@ -1781,94 +1882,81 @@ unicodeSyntaxEnabled :: Int -> Bool unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit unboxedTuplesEnabled :: Int -> Bool unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit -standaloneDerivingEnabled :: Int -> Bool -standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit +datatypeContextsEnabled :: Int -> Bool +datatypeContextsEnabled flags = testBit flags datatypeContextsBit qqEnabled :: Int -> Bool qqEnabled flags = testBit flags qqBit -- inRulePrag :: Int -> Bool -- inRulePrag flags = testBit flags inRulePragBit rawTokenStreamEnabled :: Int -> Bool rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit -newQualOps :: Int -> Bool -newQualOps flags = testBit flags newQualOpsBit -oldQualOps :: Int -> Bool -oldQualOps flags = not (newQualOps flags) alternativeLayoutRule :: Int -> Bool alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit +relaxedLayout :: Int -> Bool +relaxedLayout flags = testBit flags relaxedLayoutBit +nondecreasingIndentation :: Int -> Bool +nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit -- PState for parsing options pragmas -- -pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState -pragState dynflags buf loc = - PState { - buffer = buf, - messages = emptyMessages, - dflags = dynflags, - last_loc = mkSrcSpan loc loc, - last_len = 0, - loc = loc, - extsBitmap = 0, - context = [], - lex_state = [bol, option_prags, 0], - alr_pending_implicit_tokens = [], - alr_next_token = Nothing, - alr_last_loc = noSrcSpan, - alr_context = [], - alr_expecting_ocurly = Nothing, - alr_justClosedExplicitLetBlock = False - } - +pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState +pragState dynflags buf loc = (mkPState dynflags buf loc) { + lex_state = [bol, option_prags, 0] + } -- create a parse state -- -mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState -mkPState buf loc flags = +mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState +mkPState flags buf loc = PState { - buffer = buf, + buffer = buf, dflags = flags, messages = emptyMessages, - last_loc = mkSrcSpan loc loc, + last_loc = mkRealSrcSpan loc loc, last_len = 0, loc = loc, extsBitmap = fromIntegral bitmap, context = [], lex_state = [bol, 0], - -- we begin in the layout state if toplev_layout is set alr_pending_implicit_tokens = [], alr_next_token = Nothing, - alr_last_loc = noSrcSpan, + alr_last_loc = alrInitialLoc (fsLit ""), alr_context = [], alr_expecting_ocurly = Nothing, - alr_justClosedExplicitLetBlock = False + alr_justClosedExplicitLetBlock = False, + code_type_bracket_depth = [], + code_type_bracket_depth_stack = [] } where - 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 - .|. qqBit `setBitIf` dopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` dopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` dopt Opt_ExplicitForAll 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 - .|. recBit `setBitIf` dopt Opt_DoRec flags - .|. recBit `setBitIf` dopt Opt_Arrows 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 + bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. arrowsBit `setBitIf` xopt Opt_Arrows flags + .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags + .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags + .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags + .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags + .|. haddockBit `setBitIf` dopt Opt_Haddock flags + .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. recBit `setBitIf` xopt Opt_DoRec flags + .|. recBit `setBitIf` xopt Opt_Arrows flags + .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags + .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags + .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags - .|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags - .|. alternativeLayoutRuleBit `setBitIf` dopt Opt_AlternativeLayoutRule flags + .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags + .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b - | otherwise = 0 + | otherwise = 0 addWarning :: DynFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning @@ -1891,7 +1979,7 @@ popContext = P $ \ s@(PState{ buffer = buf, context = ctx, last_len = len, last_loc = last_loc }) -> case ctx of (_:tl) -> POk s{ context = tl } () - [] -> PFailed last_loc (srcParseErr buf len) + [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len) -- Push a new layout context at the indentation of the last token read. -- This is only used at the outer level of a module when the 'module' @@ -1930,7 +2018,7 @@ srcParseErr buf len srcParseFail :: P a srcParseFail = P $ \PState{ buffer = buf, last_len = len, last_loc = last_loc } -> - PFailed last_loc (srcParseErr buf len) + PFailed (RealSrcSpan last_loc) (srcParseErr buf len) -- A lexical error is reported at a particular position in the source file, -- not over a token range. @@ -1948,11 +2036,11 @@ lexer :: (Located Token -> P a) -> P a lexer cont = do alr <- extension alternativeLayoutRule let lexTokenFun = if alr then lexTokenAlr else lexToken - tok@(L _span _tok__) <- lexTokenFun - --trace ("token: " ++ show _tok__) $ do - cont tok + (L span tok) <- lexTokenFun + --trace ("token: " ++ show tok) $ do + cont (L (RealSrcSpan span) tok) -lexTokenAlr :: P (Located Token) +lexTokenAlr :: P (RealLocated Token) lexTokenAlr = do mPending <- popPendingImplicitToken t <- case mPending of Nothing -> @@ -1974,7 +2062,7 @@ lexTokenAlr = do mPending <- popPendingImplicitToken _ -> return () return t -alternativeLayoutRuleToken :: Located Token -> P (Located Token) +alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) alternativeLayoutRuleToken t = do context <- getALRContext lastLoc <- getAlrLastLoc @@ -1982,11 +2070,10 @@ alternativeLayoutRuleToken t justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock setJustClosedExplicitLetBlock False dflags <- getDynFlags - let transitional = dopt Opt_AlternativeLayoutRuleTransitional dflags + let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags thisLoc = getLoc t thisCol = srcSpanStartCol thisLoc - newLine = (lastLoc == noSrcSpan) - || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc) + newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc case (unLoc t, context, mExpectingOCurly) of -- This case handles a GHC extension to the original H98 -- layout rule... @@ -2046,7 +2133,7 @@ alternativeLayoutRuleToken t (ITwhere, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional - thisLoc + (RealSrcSpan thisLoc) (transitionalAlternativeLayoutWarning "`where' clause at the same depth as implicit layout block") setALRContext ls @@ -2054,6 +2141,18 @@ alternativeLayoutRuleToken t -- Note that we use lastLoc, as we may need to close -- more layouts, or give a semicolon return (L lastLoc ITccurly) + -- This next case is to handle a transitional issue: + (ITvbar, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + (RealSrcSpan thisLoc) + (transitionalAlternativeLayoutWarning + "`|' at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) (_, ALRLayout _ col : ls, _) | newLine && thisCol == col -> do setNextToken t @@ -2064,10 +2163,8 @@ alternativeLayoutRuleToken t -- Note that we use lastLoc, as we may need to close -- more layouts, or give a semicolon return (L lastLoc ITccurly) - (u, _, _) - | isALRopen u -> - do setALRContext (ALRNoLayout (containsCommas u) False : context) - return t + -- We need to handle close before open, as 'then' is both + -- an open and a close (u, _, _) | isALRclose u -> case context of @@ -2076,13 +2173,24 @@ alternativeLayoutRuleToken t setNextToken t return (L thisLoc ITccurly) ALRNoLayout _ isLet : ls -> - do setALRContext ls + do let ls' = if isALRopen u + then ALRNoLayout (containsCommas u) False : ls + else ls + setALRContext ls' when isLet $ setJustClosedExplicitLetBlock True return t [] -> - -- XXX This is an error in John's code, but - -- it looks reachable to me at first glance - return t + do let ls = if isALRopen u + then [ALRNoLayout (containsCommas u) False] + else ls + setALRContext ls + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) False : context) + return t (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> do setALRContext ls setPendingImplicitTokens [t] @@ -2112,6 +2220,7 @@ transitionalAlternativeLayoutWarning msg isALRopen :: Token -> Bool isALRopen ITcase = True isALRopen ITif = True +isALRopen ITthen = True isALRopen IToparen = True isALRopen ITobrack = True isALRopen ITocurly = True @@ -2123,6 +2232,7 @@ isALRopen _ = False isALRclose :: Token -> Bool isALRclose ITof = True isALRclose ITthen = True +isALRclose ITelse = True isALRclose ITcparen = True isALRclose ITcbrack = True isALRclose ITccurly = True @@ -2150,14 +2260,14 @@ topNoLayoutContainsCommas [] = False topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b -lexToken :: P (Located Token) +lexToken :: P (RealLocated Token) lexToken = do inp@(AI loc1 buf) <- getInput sc <- getLexState exts <- getExts case alexScanUser exts inp sc of AlexEOF -> do - let span = mkSrcSpan loc1 loc1 + let span = mkRealSrcSpan loc1 loc1 setLastToken span 0 return (L span ITeof) AlexError (AI loc2 buf) -> @@ -2167,12 +2277,12 @@ lexToken = do lexToken AlexToken inp2@(AI end buf2) _ t -> do setInput inp2 - let span = mkSrcSpan loc1 end + let span = mkRealSrcSpan loc1 end let bytes = byteDiff buf buf2 span `seq` setLastToken span bytes t span buf bytes -reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a +reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a reportLexError loc1 loc2 buf str | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") | otherwise = @@ -2183,9 +2293,10 @@ reportLexError loc1 loc2 buf str then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) -lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token] +lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] lexTokenStream buf loc dflags = unP go initState - where initState = mkPState buf loc (dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream) + where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream + initState = mkPState dflags' buf loc go = do ltok <- lexer return case ltok of @@ -2208,8 +2319,11 @@ ignoredPrags = Map.fromList (map ignored pragmas) pragmas = options_pragmas ++ ["cfiles", "contract"] oneWordPrags = Map.fromList([("rules", rulePrag), - ("inline", token (ITinline_prag True)), - ("notinline", token (ITinline_prag False)), + ("inline", token (ITinline_prag Inline FunLike)), + ("inlinable", token (ITinline_prag Inlinable FunLike)), + ("inlineable", token (ITinline_prag Inlinable FunLike)), + -- Spelling variant + ("notinline", token (ITinline_prag NoInline FunLike)), ("specialize", token ITspec_prag), ("source", token ITsource_prag), ("warning", token ITwarning_prag), @@ -2218,13 +2332,15 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("generated", token ITgenerated_prag), ("core", token ITcore_prag), ("unpack", token ITunpack_prag), - ("ann", token ITann_prag)]) + ("ann", token ITann_prag), + ("vectorize", token ITvect_prag), + ("novectorize", token ITnovect_prag)]) -twoWordPrags = Map.fromList([("inline conlike", token (ITinline_conlike_prag True)), - ("notinline conlike", token (ITinline_conlike_prag False)), +twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), + ("notinline conlike", token (ITinline_prag NoInline ConLike)), ("specialize inline", token (ITspec_inline_prag True)), - ("specialize notinline", token (ITspec_inline_prag False))]) - + ("specialize notinline", token (ITspec_inline_prag False)), + ("vectorize scalar", token ITvect_scalar_prag)]) dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of @@ -2243,6 +2359,8 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) canonical prag' = case prag' of "noinline" -> "notinline" "specialise" -> "specialize" + "vectorise" -> "vectorize" + "novectorise" -> "novectorize" "constructorlike" -> "conlike" _ -> prag' canon_ws s = unwords (map canonical (words s))