X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=d6b2322725485da647fafa227370a808253679a2;hp=aaeaca73873c79f2a70d52800f6987f1796a005b;hb=9176377bf7d989919fe7d27cad1f56bd9c4e7b6b;hpb=f4b727487a65e6b611bbaafbd2207bd63a8df706 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index aaeaca7..d6b2322 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -32,6 +32,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 +51,11 @@ module Lexer ( failLocMsgP, failSpanMsgP, srcParseFail, getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, getLexState, popLexState, pushLexState, - extension, standaloneDerivingEnabled, bangPatEnabled, + extension, bangPatEnabled, datatypeContextsEnabled, addWarning, + incrBracketDepth, decrBracketDepth, getParserBrakDepth, lexTokenStream ) where @@ -66,6 +69,7 @@ import UniqFM import DynFlags import Module import Ctype +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) ) import Util ( readRational ) import Control.Monad @@ -139,7 +143,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 +213,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 +289,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,8 +311,12 @@ $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 } } <0> { @@ -318,6 +326,15 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } } <0> { + "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol } + { special ITopenBrak } + "]>" / { ifExtension hetMetEnabled } { special ITcloseBrak } + "~~" / { ifExtension hetMetEnabled } { special ITescape } + "%%" / { ifExtension hetMetEnabled } { special ITdoublePercent } + "~~$" / { ifExtension hetMetEnabled } { special ITescapeDollar } +} + +<0> { \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } } @@ -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,8 @@ data Token | IToptions_prag String | ITinclude_prag String | ITlanguage_prag + | ITvect_prag + | ITvect_scalar_prag | ITdotdot -- reserved symbols | ITcolon @@ -506,8 +523,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 @@ -565,6 +582,13 @@ data Token | ITLarrowtail -- -<< | ITRarrowtail -- >>- + -- Heterogeneous Metaprogramming extension + | ITopenBrak -- <[ + | ITcloseBrak -- ]> + | ITescape -- ~~ + | ITescapeDollar -- ~~$ + | ITdoublePercent -- %% + | ITunknown String -- Used when the lexer can't make sense of it | ITeof -- end of file token @@ -596,6 +620,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 +683,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), @@ -701,7 +727,6 @@ reservedSymsFM = listToUFM $ explicitForallEnabled i) ,("→", ITrarrow, unicodeSyntaxEnabled) ,("←", ITlarrow, unicodeSyntaxEnabled) - ,("⋯", ITdotdot, unicodeSyntaxEnabled) ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) @@ -750,6 +775,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 span (text "Missing block") + pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState act span buf len @@ -1100,10 +1138,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 @@ -1180,7 +1220,7 @@ lex_string :: String -> P Token lex_string s = do i <- getInput case alexGetChar' i of - Nothing -> lit_error + Nothing -> lit_error i Just ('"',i) -> do setInput i @@ -1205,21 +1245,25 @@ lex_string s = do Just ('\\',i) | Just ('&',i) <- next -> do setInput i; lex_string s - | Just (c,i) <- next, is_space c -> do + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + -- is_space only works for <= '\x7f' (#3751) setInput i; lex_stringgap s where next = alexGetChar' i - Just (c, i) -> do - c' <- lex_char c i - lex_string (c':s) + Just (c, i1) -> do + case c of + '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) + c | isAny c -> do setInput i1; lex_string (c:s) + _other -> lit_error i lex_stringgap :: String -> P Token lex_stringgap s = do - c <- getCharOrFail + i <- getInput + c <- getCharOrFail i case c of '\\' -> lex_string s c | is_space c -> lex_stringgap s - _other -> lit_error + _other -> lit_error i lex_char_tok :: Action @@ -1233,24 +1277,25 @@ 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 - Nothing -> lit_error + Nothing -> lit_error i1 Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' th_exts <- extension thEnabled if th_exts then do setInput i2 return (L (mkSrcSpan loc end2) ITtyQuote) - else lit_error + else lit_error i1 Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash setInput i2 lit_ch <- lex_escape - mc <- getCharOrFail -- Trailing quote + i3 <- getInput + mc <- getCharOrFail i3 -- Trailing quote if mc == '\'' then finish_char_tok loc lit_ch - else do setInput i2; lit_error + else lit_error i3 Just (c, i2@(AI _end2 _)) - | not (isAny c) -> lit_error + | not (isAny c) -> lit_error i1 | otherwise -> -- We've seen 'x, where x is a valid character @@ -1265,7 +1310,7 @@ lex_char_tok span _buf _len = do -- We've seen ' th_exts <- extension thEnabled let (AI end _) = i1 if th_exts then return (L (mkSrcSpan loc end) ITvarQuote) - else do setInput i2; lit_error + else lit_error i2 finish_char_tok :: SrcLoc -> Char -> P (Located Token) finish_char_tok loc ch -- We've already seen the closing quote @@ -1282,20 +1327,14 @@ finish_char_tok loc ch -- We've already seen the closing quote else do return (L (mkSrcSpan loc end) (ITchar ch)) -lex_char :: Char -> AlexInput -> P Char -lex_char c inp = do - case c of - '\\' -> do setInput inp; lex_escape - c | isAny c -> do setInput inp; return c - _other -> lit_error - isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c | otherwise = is_any c lex_escape :: P Char lex_escape = do - c <- getCharOrFail + i0 <- getInput + c <- getCharOrFail i0 case c of 'a' -> return '\a' 'b' -> return '\b' @@ -1307,10 +1346,11 @@ lex_escape = do '\\' -> return '\\' '"' -> return '\"' '\'' -> return '\'' - '^' -> do c <- getCharOrFail + '^' -> do i1 <- getInput + c <- getCharOrFail i1 if c >= '@' && c <= '_' then return (chr (ord c - ord '@')) - else lit_error + else lit_error i1 'x' -> readNum is_hexdigit 16 hexDigit 'o' -> readNum is_octdigit 8 octDecDigit @@ -1319,10 +1359,10 @@ lex_escape = do c1 -> do i <- getInput case alexGetChar' i of - Nothing -> lit_error + Nothing -> lit_error i0 Just (c2,i2) -> case alexGetChar' i2 of - Nothing -> do setInput i2; lit_error + Nothing -> do lit_error i0 Just (c3,i3) -> let str = [c1,c2,c3] in case [ (c,rest) | (p,c) <- silly_escape_chars, @@ -1333,15 +1373,15 @@ lex_escape = do (escape_char,_:_):_ -> do setInput i2 return escape_char - [] -> lit_error + [] -> lit_error i0 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char readNum is_digit base conv = do i <- getInput - c <- getCharOrFail + c <- getCharOrFail i if is_digit c then readNum2 is_digit base conv (conv c) - else do setInput i; lit_error + else lit_error i readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char readNum2 is_digit base conv i = do @@ -1350,11 +1390,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 + setInput input; return (chr i) + silly_escape_chars :: [(String, Char)] silly_escape_chars = [ @@ -1398,12 +1440,11 @@ silly_escape_chars = [ -- the position of the error in the buffer. This is so that we can report -- a correct location to the user, but also so we can detect UTF-8 decoding -- errors if they occur. -lit_error :: P a -lit_error = lexError "lexical error in string/character literal" +lit_error :: AlexInput -> P a +lit_error i = do setInput i; lexError "lexical error in string/character literal" -getCharOrFail :: P Char -getCharOrFail = do - i <- getInput +getCharOrFail :: AlexInput -> P Char +getCharOrFail i = do case alexGetChar' i of Nothing -> lexError "unexpected end-of-file in string/character literal" Just (c,i) -> do setInput i; return c @@ -1413,8 +1454,9 @@ getCharOrFail = do lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do - let quoter = reverse $ takeWhile (/= '$') - $ reverse $ lexemeToString buf (len - 1) + let quoter = tail (lexemeToString buf (len - 1)) + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' quoteStart <- getSrcLoc quote <- lex_quasiquote "" end <- getSrcLoc @@ -1427,7 +1469,7 @@ lex_quasiquote :: String -> P String lex_quasiquote s = do i <- getInput case alexGetChar' i of - Nothing -> lit_error + Nothing -> lit_error i Just ('\\',i) | Just ('|',i) <- next -> do @@ -1497,7 +1539,11 @@ data PState = PState { alr_context :: [ALRContext], -- Are we expecting a '{'? If it's Just, then the ALRLayout tells -- us what sort of layout the '{' will open: - alr_expecting_ocurly :: Maybe ALRLayout + 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, + code_type_bracket_depth :: Int } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the @@ -1506,6 +1552,7 @@ data PState = PState { -- implement pushCurrentContext (which is only called from one place). data ALRContext = ALRNoLayout Bool{- does it contain commas? -} + Bool{- is it a 'let' block? -} | ALRLayout ALRLayout Int data ALRLayout = ALRLayoutLet | ALRLayoutWhere @@ -1563,6 +1610,13 @@ setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () setSrcLoc :: SrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () +incrBracketDepth :: P () +incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)+1}) () +decrBracketDepth :: P () +decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)-1}) () +getParserBrakDepth :: P Int +getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s) + getSrcLoc :: P SrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc @@ -1612,7 +1666,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 @@ -1644,6 +1698,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} () @@ -1658,6 +1717,15 @@ popNextToken = P $ \s@PState{ alr_next_token = m } -> POk (s {alr_next_token = Nothing}) m +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + setAlrLastLoc :: SrcSpan -> P () setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () @@ -1670,9 +1738,24 @@ getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs setALRContext :: [ALRContext] -> P () setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () +getJustClosedExplicitLetBlock :: P Bool +getJustClosedExplicitLetBlock + = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b + +setJustClosedExplicitLetBlock :: Bool -> P () +setJustClosedExplicitLetBlock b + = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () + setNextToken :: Located Token -> P () setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + popPendingImplicitToken :: P (Maybe (Located Token)) popPendingImplicitToken = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> @@ -1690,7 +1773,7 @@ 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 @@ -1724,8 +1807,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 @@ -1734,12 +1817,16 @@ 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 @@ -1749,6 +1836,8 @@ 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 @@ -1769,47 +1858,32 @@ 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 - } - +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 -> SrcLoc -> PState +mkPState flags buf loc = PState { buffer = buf, dflags = flags, @@ -1820,37 +1894,40 @@ mkPState buf loc flags = 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_context = [], - alr_expecting_ocurly = Nothing + alr_expecting_ocurly = Nothing, + alr_justClosedExplicitLetBlock = False, + code_type_bracket_depth = 0 } 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 + bitmap = genericsBit `setBitIf` xopt Opt_Generics flags + .|. 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` 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 + .|. 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 .|. 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 @@ -1955,6 +2032,8 @@ lexTokenAlr = do mPending <- popPendingImplicitToken ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITmdo -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) _ -> return () return t @@ -1963,16 +2042,23 @@ alternativeLayoutRuleToken t = do context <- getALRContext lastLoc <- getAlrLastLoc mExpectingOCurly <- getAlrExpectingOCurly - let thisLoc = getLoc t + justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock + setJustClosedExplicitLetBlock False + dflags <- getDynFlags + let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags + thisLoc = getLoc t thisCol = srcSpanStartCol thisLoc newLine = (lastLoc == noSrcSpan) || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc) case (unLoc t, context, mExpectingOCurly) of -- This case handles a GHC extension to the original H98 -- layout rule... - (ITocurly, _, Just _) -> + (ITocurly, _, Just alrLayout) -> do setAlrExpectingOCurly Nothing - setALRContext (ALRNoLayout (containsCommas ITocurly) : context) + let isLet = case alrLayout of + ALRLayoutLet -> True + _ -> False + setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) return t -- ...and makes this case unnecessary {- @@ -2011,11 +2097,38 @@ alternativeLayoutRuleToken t (ITeof, _, _) -> return t -- the other ITeof case omitted; general case below covers it + (ITin, _, _) + | justClosedExplicitLetBlock -> + return t (ITin, ALRLayout ALRLayoutLet _ : ls, _) | newLine -> do setPendingImplicitTokens [t] setALRContext ls return (L thisLoc ITccurly) + -- This next case is to handle a transitional issue: + (ITwhere, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + thisLoc + (transitionalAlternativeLayoutWarning + "`where' clause 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) + -- This next case is to handle a transitional issue: + (ITvbar, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + 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 @@ -2026,10 +2139,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) : 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 @@ -2037,13 +2148,25 @@ alternativeLayoutRuleToken t do setALRContext ls setNextToken t return (L thisLoc ITccurly) - ALRNoLayout _ : ls -> - do setALRContext ls + ALRNoLayout _ isLet : 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] @@ -2065,19 +2188,27 @@ alternativeLayoutRuleToken t -- the other ITwhere case omitted; general case below covers it (_, _, _) -> return t +transitionalAlternativeLayoutWarning :: String -> SDoc +transitionalAlternativeLayoutWarning msg + = text "transitional layout will not be accepted in the future:" + $$ text msg + isALRopen :: Token -> Bool -isALRopen ITcase = True -isALRopen ITif = True -isALRopen IToparen = True -isALRopen ITobrack = True -isALRopen ITocurly = True +isALRopen ITcase = True +isALRopen ITif = True +isALRopen ITthen = True +isALRopen IToparen = True +isALRopen ITobrack = True +isALRopen ITocurly = True -- GHC Extensions: -isALRopen IToubxparen = True -isALRopen _ = False +isALRopen IToubxparen = True +isALRopen ITparenEscape = True +isALRopen _ = False isALRclose :: Token -> Bool isALRclose ITof = True isALRclose ITthen = True +isALRclose ITelse = True isALRclose ITcparen = True isALRclose ITcbrack = True isALRclose ITccurly = True @@ -2103,7 +2234,7 @@ containsCommas _ = False topNoLayoutContainsCommas :: [ALRContext] -> Bool topNoLayoutContainsCommas [] = False topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls -topNoLayoutContainsCommas (ALRNoLayout b : _) = b +topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b lexToken :: P (Located Token) lexToken = do @@ -2140,7 +2271,8 @@ reportLexError loc1 loc2 buf str lexTokenStream :: StringBuffer -> SrcLoc -> 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 @@ -2163,8 +2295,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), @@ -2173,13 +2308,14 @@ 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)]) -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 @@ -2198,6 +2334,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) canonical prag' = case prag' of "noinline" -> "notinline" "specialise" -> "specialize" + "vectorise" -> "vectorize" "constructorlike" -> "conlike" _ -> prag' canon_ws s = unwords (map canonical (words s))