X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=cae53499fedf05324887c9b17af7f4856367a02b;hp=85d4d12dca714cbb6cf4d5780381cdf7a5e19834;hb=60762c678c83e370609001addc8f52efcd657139;hpb=16c7844d29b7b90e6cf432ec646f70d466ca9cc9 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 85d4d12..cae5349 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -31,15 +31,15 @@ -- qualified varids. { -{-# OPTIONS -Wwarn -w #-} --- The above -Wwarn supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details --- --- Note that Alex itself generates code with with some unused bindings and --- without type signatures, so removing the flag might not be possible. +-- XXX The above flags turn off warnings in the generated code: +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-- But alex still generates some code that causes the "lazy unlifted bindings" +-- warning, and old compilers don't know about it so we can't easily turn +-- it off, so for now we use the sledge hammer: +{-# OPTIONS_GHC -w #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -702,6 +702,14 @@ reservedSymsFM = listToUFM $ ,("→", ITrarrow, unicodeSyntaxEnabled) ,("←", ITlarrow, unicodeSyntaxEnabled) ,("⋯", ITdotdot, unicodeSyntaxEnabled) + + ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤛", ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + ,("⤜", ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) + + ,("★", ITstar, unicodeSyntaxEnabled) + -- ToDo: ideally, → and ∷ should be "specials", so that they cannot -- form part of a large operator. This would let us have a better -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). @@ -1127,7 +1135,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) 0) + setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) -- subtract one: the line number refers to the *following* line _ <- popLexState pushLexState code @@ -1136,6 +1144,7 @@ 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)) _ <- popLexState pushLexState code @@ -1281,7 +1290,7 @@ finish_char_tok loc ch -- We've already seen the closing quote return (L (mkSrcSpan loc end) (ITprimchar ch)) _other -> return (L (mkSrcSpan loc end) (ITchar ch)) - else do + else do return (L (mkSrcSpan loc end) (ITchar ch)) lex_char :: Char -> AlexInput -> P Char @@ -1490,10 +1499,19 @@ data PState = PState { 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], + -- 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), + -- This is what we consider to be the locatino of the last token + -- emitted: alr_last_loc :: SrcSpan, + -- The stack of layout contexts: 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 } -- last_loc and last_len are used when generating error messages, @@ -1973,8 +1991,17 @@ alternativeLayoutRuleToken t mExpectingOCurly <- getAlrExpectingOCurly let thisLoc = getLoc t thisCol = srcSpanStartCol thisLoc - newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc + 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 _) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRNoLayout (containsCommas ITocurly) : context) + return t + -- ...and makes this case unnecessary + {- -- I think our implicit open-curly handling is slightly -- different to John's, in how it interacts with newlines -- and "in" @@ -1982,42 +2009,49 @@ alternativeLayoutRuleToken t do setAlrExpectingOCurly Nothing setNextToken t lexTokenAlr + -} (_, ALRLayout _ col : ls, Just expectingOCurly) - | thisCol > col -> + | (thisCol > col) || + (thisCol == col && + isNonDecreasingIntentation expectingOCurly) -> do setAlrExpectingOCurly Nothing setALRContext (ALRLayout expectingOCurly thisCol : context) setNextToken t return (L thisLoc ITocurly) | otherwise -> do setAlrExpectingOCurly Nothing - setPendingImplicitTokens [L thisLoc ITccurly] + setPendingImplicitTokens [L lastLoc ITccurly] setNextToken t - return (L thisLoc ITocurly) + return (L lastLoc ITocurly) (_, _, Just expectingOCurly) -> do setAlrExpectingOCurly Nothing setALRContext (ALRLayout expectingOCurly thisCol : context) setNextToken t return (L thisLoc ITocurly) + -- We do the [] cases earlier than in the spec, as we + -- have an actual EOF token + (ITeof, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITccurly) + (ITeof, _, _) -> + return t + -- the other ITeof case omitted; general case below covers it (ITin, ALRLayout ALRLayoutLet _ : ls, _) | newLine -> do setPendingImplicitTokens [t] setALRContext ls return (L thisLoc ITccurly) - (_, ls@(ALRLayout _ col : _), _) - | newLine && thisCol <= col -> - do let f ls'@(ALRLayout _ col' : ls'') - | thisCol < col' = case f ls'' of - (ts, ls''') -> - (L thisLoc ITccurly : ts, ls''') - | thisCol == col' = ([L thisLoc ITsemi], ls') - | otherwise = ([], ls') - f ls' = ([], ls') - case f ls of - (t' : ts, ls') -> - do setPendingImplicitTokens ts - setNextToken t - return t' - _ -> panic "Layout rule: [] when considering newline" + (_, ALRLayout _ col : ls, _) + | newLine && thisCol == col -> + do setNextToken t + return (L thisLoc ITsemi) + | newLine && thisCol < col -> + do 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) (u, _, _) | isALRopen u -> do setALRContext (ALRNoLayout (containsCommas u) : context) @@ -2040,7 +2074,7 @@ alternativeLayoutRuleToken t do setALRContext ls setPendingImplicitTokens [t] return (L thisLoc ITccurly) - (ITin, _ : ls, _) -> + (ITin, ALRLayout _ _ : ls, _) -> do setALRContext ls setNextToken t return (L thisLoc ITccurly) @@ -2055,13 +2089,6 @@ alternativeLayoutRuleToken t setPendingImplicitTokens [t] return (L thisLoc ITccurly) -- the other ITwhere case omitted; general case below covers it - -- The first [] case comes before the general case, as we - -- have an actual EOF token - (ITeof, ALRLayout _ _ : ls, _) -> - do setALRContext ls - setNextToken t - return (L thisLoc ITccurly) - -- the other ITeof case omitted; general case below covers it (_, _, _) -> return t isALRopen :: Token -> Bool @@ -2070,6 +2097,8 @@ isALRopen ITif = True isALRopen IToparen = True isALRopen ITobrack = True isALRopen ITocurly = True +-- GHC Extensions: +isALRopen IToubxparen = True isALRopen _ = False isALRclose :: Token -> Bool @@ -2078,11 +2107,23 @@ isALRclose ITthen = True isALRclose ITcparen = True isALRclose ITcbrack = True isALRclose ITccurly = True +-- GHC Extensions: +isALRclose ITcubxparen = True isALRclose _ = False +isNonDecreasingIntentation :: ALRLayout -> Bool +isNonDecreasingIntentation ALRLayoutDo = True +isNonDecreasingIntentation _ = False + containsCommas :: Token -> Bool containsCommas IToparen = True containsCommas ITobrack = True +-- John doesn't have {} as containing commas, but records contain them, +-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs +-- (defaultInstallDirs). +containsCommas ITocurly = True +-- GHC Extensions: +containsCommas IToubxparen = True containsCommas _ = False topNoLayoutContainsCommas :: [ALRContext] -> Bool