X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=1037a1a589cf71a65da61328fc656ea48dbccd8e;hb=5205edda3f16a6e93e5e0749f3dcb3f7831a317e;hp=fb7a53543324da5cb3a4afa0ebce5c699fecd452;hpb=bc65cfb23f1715a7a172e06ab8f067ca68f84e90;p=ghc-hetmet.git

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index fb7a535..1037a1a 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -32,7 +32,7 @@
 
 {
 {-# OPTIONS -Wwarn -w #-}
--- The above warning supression flag is a temporary kludge.
+-- 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
@@ -46,6 +46,7 @@
 module Lexer (
    Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc, 
+   getPState,
    failLocMsgP, failSpanMsgP, srcParseFail,
    getMessages,
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
@@ -57,7 +58,6 @@ module Lexer (
 
 import Bag
 import ErrUtils
-import Maybe
 import Outputable
 import StringBuffer
 import FastString
@@ -65,12 +65,13 @@ import SrcLoc
 import UniqFM
 import DynFlags
 import Ctype
-import Util		( maybePrefixMatch, readRational )
+import Util		( readRational )
 
 import Control.Monad
 import Data.Bits
 import Data.Char
 import Data.List
+import Data.Maybe
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Ratio
@@ -224,8 +225,8 @@ $tab+         { warn Opt_WarnTabs (text "Tab character") }
 
 <0,option_prags> \n				{ begin bol }
 
-"{-#" $whitechar* (line|LINE) / { notFollowedByPragmaChar }
-                            { begin line_prag2 }
+"{-#" $whitechar* $pragmachar+ / { known_pragma linePrags }
+                                { dispatch_pragmas linePrags }
 
 -- single-line line pragmas, of the form
 --    # <line> "<file>" <extra-stuff> \n
@@ -453,7 +454,6 @@ data Token
   | ITstdcallconv
   | ITccallconv
   | ITprimcallconv
-  | ITdotnet
   | ITmdo
   | ITfamily
   | ITgroup
@@ -530,8 +530,6 @@ data Token
 
   | ITdupipvarid   FastString	-- GHC extension: implicit param: ?x
 
-  | ITpragma StringBuffer
-
   | ITchar       Char
   | ITstring     FastString
   | ITinteger    Integer
@@ -544,7 +542,7 @@ data Token
   | ITprimfloat  Rational
   | ITprimdouble Rational
 
-  -- MetaHaskell extension tokens
+  -- Template Haskell extension tokens
   | ITopenExpQuote  		--  [| or [e|
   | ITopenPatQuote		--  [p|
   | ITopenDecQuote		--  [d|
@@ -663,9 +661,8 @@ reservedWordsFM = listToUFM $
 	( "stdcall",    ITstdcallconv,	 bit ffiBit),
 	( "ccall",      ITccallconv,	 bit ffiBit),
 	( "prim",       ITprimcallconv,	 bit ffiBit),
-	( "dotnet",     ITdotnet,	 bit ffiBit),
 
-	( "rec",	ITrec,		 bit arrowsBit),
+	( "rec",	ITrec,		 bit recBit),
 	( "proc",	ITproc,		 bit arrowsBit)
      ]
 
@@ -758,10 +755,6 @@ notFollowedBySymbol :: AlexAccPred Int
 notFollowedBySymbol _ _ _ (AI _ _ buf)
   = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
 
-notFollowedByPragmaChar :: AlexAccPred Int
-notFollowedByPragmaChar _ _ _ (AI _ _ buf)
-  = nextCharIs buf (\c -> not (isAlphaNum c || c == '_'))
-
 -- We must reject doc comments as being ordinary comments everywhere.
 -- In some cases the doc comment will be selected as the lexeme due to
 -- maximal munch, but not always, because the nested comment rule is
@@ -887,12 +880,12 @@ withLexedDocType lexDocComment = do
 -- RULES pragmas turn on the forall and '.' keywords, and we turn them
 -- off again at the end of the pragma.
 rulePrag :: Action
-rulePrag span _ _ = do
+rulePrag span _buf _len = do
   setExts (.|. bit inRulePragBit)
   return (L span ITrules_prag)
 
 endPrag :: Action
-endPrag span _ _ = do
+endPrag span _buf _len = do
   setExts (.&. complement (bit inRulePragBit))
   return (L span ITclose_prag)
 
@@ -1223,7 +1216,7 @@ lex_char_tok :: Action
 -- Here we are basically parsing character literals, such as 'x' or '\n'
 -- but, when Template Haskell is on, we additionally spot
 -- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, 
--- but WIHTOUT CONSUMING the x or T part  (the parser does that).
+-- but WITHOUT CONSUMING the x or T part  (the parser does that).
 -- So we have to do two characters of lookahead: when we see 'x we need to
 -- see if there's a trailing quote
 lex_char_tok span _buf _len = do	-- We've seen '
@@ -1323,7 +1316,7 @@ lex_escape = do
 		Just (c3,i3) -> 
 		   let str = [c1,c2,c3] in
 		   case [ (c,rest) | (p,c) <- silly_escape_chars,
-			      	     Just rest <- [maybePrefixMatch p str] ] of
+			      	     Just rest <- [stripPrefix p str] ] of
 			  (escape_char,[]):_ -> do
 				setInput i3
 				return escape_char
@@ -1519,6 +1512,9 @@ failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
 failSpanMsgP :: SrcSpan -> SDoc -> P a
 failSpanMsgP span msg = P $ \_ -> PFailed span msg
 
+getPState :: P PState
+getPState = P $ \s -> POk s s
+
 extension :: (Int -> Bool) -> P Bool
 extension p = P $ \s -> POk s (p $! extsBitmap s)
 
@@ -1676,6 +1672,8 @@ 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
 
 always :: Int -> Bool
 always           _     = True
@@ -1757,26 +1755,23 @@ mkPState buf loc flags  =
     }
     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_ScopedTypeVariables flags
-	       .|. explicitForallBit `setBitIf` dopt Opt_LiberalTypeSynonyms flags
-	       .|. explicitForallBit `setBitIf` dopt Opt_PolymorphicComponents flags
-	       .|. explicitForallBit `setBitIf` dopt Opt_ExistentialQuantification flags
-	       .|. explicitForallBit `setBitIf` dopt Opt_Rank2Types flags
-	       .|. explicitForallBit `setBitIf` dopt Opt_RankNTypes 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
-	       .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags
-	       .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples 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
                .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
@@ -1907,6 +1902,8 @@ lexTokenStream buf loc dflags = unP go initState
               L _ ITeof -> return []
               _ -> liftM (ltok:) go
 
+linePrags = Map.singleton "line" (begin line_prag2)
+
 fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
                                  ("options_ghc", lex_string_prag IToptions_prag),
                                  ("options_haddock", lex_string_prag ITdocOptions),
@@ -1945,14 +1942,14 @@ dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToStr
                                        Nothing -> lexError "unknown pragma"
 
 known_pragma :: Map String Action -> AlexAccPred Int
-known_pragma prags q r len (AI s t buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags)
-                                          && (notFollowedByPragmaChar q r len (AI s t buf))
+known_pragma prags _ _ len (AI _ _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags)
+                                          && (nextCharIs buf (\c -> not (isAlphaNum c || c == '_')))
 
 clean_pragma :: String -> String
 clean_pragma prag = canon_ws (map toLower (unprefix prag))
-                    where unprefix prag' = (case stripPrefix "{-#" prag' of
-                                              Just rest -> rest
-                                              Nothing -> prag')
+                    where unprefix prag' = case stripPrefix "{-#" prag' of
+                                             Just rest -> rest
+                                             Nothing -> prag'
                           canonical prag' = case prag' of
                                               "noinline" -> "notinline"
                                               "specialise" -> "specialize"