X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=96660128386e20adcb50a37006fb8aa47704f7e2;hp=b20d2c011cc46a36bd1977fc2f2dc190b96bfd08;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=6ddfe9b18d4d280676aab2fa797ddbe6f8a09d6b diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index b20d2c0..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. -- ----------------------------------------------------------------------------- @@ -55,6 +56,7 @@ module Lexer ( getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, addWarning, + incrBracketDepth, incrBracketDepth1, decrBracketDepth, getParserBrakDepth, pushBracketDepth, popBracketDepth, lexTokenStream ) where @@ -70,6 +72,7 @@ import Module import Ctype import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) import Util ( readRational ) +import HsSyn (CodeFlavor(..)) import Control.Monad import Data.Bits @@ -325,6 +328,18 @@ $tab+ { warn Opt_WarnTabs (text "Warning: 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 } } @@ -335,11 +350,6 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } { token ITcubxparen } } -<0> { - "{|" / { ifExtension genericsEnabled } { token ITocurlybar } - "|}" / { ifExtension genericsEnabled } { token ITccurlybar } -} - <0,option_prags> { \( { special IToparen } \) { special ITcparen } @@ -487,6 +497,7 @@ data Token | ITlanguage_prag | ITvect_prag | ITvect_scalar_prag + | ITnovect_prag | ITdotdot -- reserved symbols | ITcolon @@ -496,6 +507,7 @@ data Token | ITvbar | ITlarrow | ITrarrow + | ITkappa | ITat | ITtilde | ITdarrow @@ -560,7 +572,7 @@ data Token | ITparenEscape -- $( | ITvarQuote -- ' | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|] + | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] -- Arrow notation extension | ITproc @@ -572,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 @@ -688,6 +709,7 @@ reservedSymsFM = listToUFM $ ,("|", ITvbar, always) ,("<-", ITlarrow, always) ,("->", ITrarrow, always) + ,("~~>", ITkappa, always) ,("@", ITat, always) ,("~", ITtilde, always) ,("=>", ITdarrow, always) @@ -726,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) @@ -769,7 +791,7 @@ hopefully_open_brace span buf len Layout prev_off : _ -> prev_off < offset _ -> True if isOK then pop_and open_brace span buf len - else failSpanMsgP span (text "Missing block") + else failSpanMsgP (RealSrcSpan span) (text "Missing block") pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState @@ -851,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 @@ -892,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 @@ -930,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 @@ -1017,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 @@ -1150,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 @@ -1159,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. @@ -1175,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 @@ -1188,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" -- ----------------------------------------------------------------------------- @@ -1200,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 @@ -1261,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 @@ -1269,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 @@ -1295,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 @@ -1307,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 @@ -1446,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 @@ -1477,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 -- ----------------------------------------------------------------------------- @@ -1505,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 @@ -1528,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 @@ -1561,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 @@ -1592,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' @@ -1690,7 +1736,7 @@ 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 @@ -1704,10 +1750,10 @@ activeContext = do ([],Nothing) -> return impt _other -> return True -setAlrLastLoc :: SrcSpan -> P () +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] @@ -1724,7 +1770,7 @@ 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}) () implicitTokenPending :: P Bool @@ -1734,14 +1780,14 @@ implicitTokenPending [] -> POk s False _ -> POk s True -popPendingImplicitToken :: P (Maybe (Located Token)) +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) @@ -1754,8 +1800,10 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- -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 @@ -1803,15 +1851,17 @@ 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 @@ -1849,20 +1899,20 @@ nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit -- PState for parsing options pragmas -- -pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState +pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState pragState dynflags buf loc = (mkPState dynflags buf loc) { lex_state = [bol, option_prags, 0] } -- create a parse state -- -mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState +mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState mkPState flags buf loc = PState { buffer = buf, dflags = flags, messages = emptyMessages, - last_loc = mkSrcSpan loc loc, + last_loc = mkRealSrcSpan loc loc, last_len = 0, loc = loc, extsBitmap = fromIntegral bitmap, @@ -1870,16 +1920,18 @@ mkPState flags buf loc = lex_state = [bol, 0], 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` xopt Opt_Generics flags - .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface 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 @@ -1927,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' @@ -1966,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. @@ -1984,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 -> @@ -2010,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 @@ -2021,8 +2073,7 @@ alternativeLayoutRuleToken t 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... @@ -2082,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 @@ -2094,7 +2145,7 @@ alternativeLayoutRuleToken t (ITvbar, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional - thisLoc + (RealSrcSpan thisLoc) (transitionalAlternativeLayoutWarning "`|' at the same depth as implicit layout block") setALRContext ls @@ -2209,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) -> @@ -2226,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 = @@ -2242,7 +2293,7 @@ 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 dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream initState = mkPState dflags' buf loc @@ -2282,7 +2333,8 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("core", token ITcore_prag), ("unpack", token ITunpack_prag), ("ann", token ITann_prag), - ("vectorize", token ITvect_prag)]) + ("vectorize", token ITvect_prag), + ("novectorize", token ITnovect_prag)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), ("notinline conlike", token (ITinline_prag NoInline ConLike)), @@ -2308,6 +2360,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) "noinline" -> "notinline" "specialise" -> "specialize" "vectorise" -> "vectorize" + "novectorise" -> "novectorize" "constructorlike" -> "conlike" _ -> prag' canon_ws s = unwords (map canonical (words s))