projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Fix some warning in Lexer
[ghc-hetmet.git] / compiler / parser / Lexer.x
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index e6de1e8..4915d99 100644 (file)
--- 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,8 +46,9 @@
 module Lexer (
    Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc, 
+   getPState, getDynFlags, withThisPackage,
    failLocMsgP, failSpanMsgP, srcParseFail,
-   getMessages,
+   getMessages, 
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
    getLexState, popLexState, pushLexState,
    extension, standaloneDerivingEnabled, bangPatEnabled,
@@ -57,13 +58,13 @@ module Lexer (
 
 import Bag
 import ErrUtils
-import Maybe
 import Outputable
 import StringBuffer
 import FastString
 import SrcLoc
 import UniqFM
 import DynFlags
+import Module
 import Ctype
 import Util            ( readRational )
 
@@ -71,6 +72,7 @@ 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
@@ -453,7 +455,6 @@ data Token
   | ITstdcallconv
   | ITccallconv
   | ITprimcallconv
-  | ITdotnet
   | ITmdo
   | ITfamily
   | ITgroup
@@ -530,8 +531,6 @@ data Token
 
   | ITdupipvarid   FastString  -- GHC extension: implicit param: ?x
 
-  | ITpragma StringBuffer
-
   | ITchar       Char
   | ITstring     FastString
   | ITinteger    Integer
@@ -544,7 +543,7 @@ data Token
   | ITprimfloat  Rational
   | ITprimdouble Rational
 
-  -- MetaHaskell extension tokens
+  -- Template Haskell extension tokens
   | ITopenExpQuote             --  [| or [e|
   | ITopenPatQuote             --  [p|
   | ITopenDecQuote             --  [d|
@@ -663,9 +662,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)
      ]
 
@@ -741,10 +739,12 @@ begin :: Int -> Action
 begin code _span _str _len = do pushLexState code; lexToken
 
 pop :: Action
-pop _span _buf _len = do popLexState; lexToken
+pop _span _buf _len = do _ <- popLexState
+                         lexToken
 
 pop_and :: Action -> Action
-pop_and act span buf len = do popLexState; act span buf len
+pop_and act span buf len = do _ <- popLexState
+                              act span buf len
 
 {-# INLINE nextCharIs #-}
 nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool
@@ -883,12 +883,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)
 
@@ -1063,10 +1063,10 @@ do_bol span _str _len = do
                return (L span ITvccurly)
            EQ -> do
                 --trace "layout: inserting ';'" $ do
-               popLexState
+               _ <- popLexState
                return (L span ITsemi)
            GT -> do
-               popLexState
+               _ <- popLexState
                lexToken
 
 -- certain keywords put us in the "layout" state, where we might
@@ -1091,7 +1091,7 @@ maybe_layout _            = return ()
 --
 new_layout_context :: Bool -> Action
 new_layout_context strict span _buf _len = do
-    popLexState
+    _ <- popLexState
     (AI _ offset _) <- getInput
     ctx <- getContext
     case ctx of
@@ -1108,7 +1108,7 @@ new_layout_context strict span _buf _len = do
 
 do_layout_left :: Action
 do_layout_left span _buf _len = do
-    popLexState
+    _ <- popLexState
     pushLexState bol  -- we must be at the start of a line
     return (L span ITvccurly)
 
@@ -1120,7 +1120,7 @@ setLine code span buf len = do
   let line = parseUnsignedInteger buf len 10 octDecDigit
   setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
        -- subtract one: the line number refers to the *following* line
-  popLexState
+  _ <- popLexState
   pushLexState code
   lexToken
 
@@ -1128,7 +1128,7 @@ setFile :: Int -> Action
 setFile code span buf len = do
   let file = lexemeToFastString (stepOn buf) (len-2)
   setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
-  popLexState
+  _ <- popLexState
   pushLexState code
   lexToken
 
@@ -1515,6 +1515,17 @@ 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
+
+getDynFlags :: P DynFlags
+getDynFlags = P $ \s -> POk s (dflags s)
+
+withThisPackage :: (PackageId -> a) -> P a
+withThisPackage f
+ = do  pkg     <- liftM thisPackage getDynFlags
+       return  $ f pkg
+
 extension :: (Int -> Bool) -> P Bool
 extension p = P $ \s -> POk s (p $! extsBitmap s)
 
@@ -1672,6 +1683,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
@@ -1753,26 +1766,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
@@ -1955,6 +1965,6 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag))
                                               "noinline" -> "notinline"
                                               "specialise" -> "specialize"
                                               "constructorlike" -> "conlike"
-                                              otherwise -> prag'
+                                              _ -> prag'
                           canon_ws s = unwords (map canonical (words s))
 }
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)