X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=4caca44a70151bdcabcbeabcb5d5a60e31a29987;hb=35cb95c2119a3d903ecfe388d3a8ef0f4ededfdd;hp=49dabf00a05eea8cc22528141a2945d0b8ab402d;hpb=e3dd39bf230380f02d73efc287226117bb2eb47f;p=ghc-hetmet.git

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 49dabf0..4caca44 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -25,6 +25,7 @@ module Lexer (
    Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc, 
    failLocMsgP, failSpanMsgP, srcParseFail,
+   getMessages,
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
    getLexState, popLexState, pushLexState,
    extension, glaExtsEnabled, bangPatEnabled
@@ -32,7 +33,8 @@ module Lexer (
 
 #include "HsVersions.h"
 
-import ErrUtils		( Message )
+import Bag
+import ErrUtils
 import Outputable
 import StringBuffer
 import FastString
@@ -43,6 +45,7 @@ import DynFlags
 import Ctype
 import Util		( maybePrefixMatch, readRational )
 
+import Control.Monad
 import Data.Bits
 import Data.Char 	( chr, isSpace )
 import Data.Ratio
@@ -56,8 +59,9 @@ import Compat.Unicode	( GeneralCategory(..), generalCategory, isPrint, isUpper )
 }
 
 $unispace    = \x05
-$whitechar   = [\ \t\n\r\f\v\xa0 $unispace]
+$whitechar   = [\ \n\r\f\v\xa0 $unispace]
 $white_no_nl = $whitechar # \n
+$tab         = \t
 
 $ascdigit  = 0-9
 $unidigit  = \x03
@@ -108,6 +112,7 @@ haskell :-
 
 -- everywhere: skip whitespace and comments
 $white_no_nl+ 				;
+$tab+         { warn Opt_WarnTabs (text "Tab character") }
 
 -- Everywhere: deal with nested comments.  We explicitly rule out
 -- pragmas, "{-#", so that we don't accidentally treat them as comments.
@@ -266,8 +271,8 @@ $white_no_nl+ 				;
 -- Haddock comments
 
 <0,glaexts> {
-  "-- " / $docsym    { multiline_doc_comment }
-  "{-" \ ? / $docsym { nested_doc_comment }
+  "-- " $docsym    / { ifExtension haddockEnabled } { multiline_doc_comment }
+  "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment }
 }
 
 -- "special" symbols
@@ -374,11 +379,6 @@ $white_no_nl+ 				;
 }
 
 {
--- work around bug in Alex 2.0
-#if __GLASGOW_HASKELL__ < 503
-unsafeAt arr i = arr ! i
-#endif
-
 -- -----------------------------------------------------------------------------
 -- The token type
 
@@ -641,13 +641,12 @@ reservedSymsFM = listToUFM $
        ,(">>-",	ITRarrowtail,	bit arrowsBit)
 
 #if __GLASGOW_HASKELL__ >= 605
-       ,("λ",	ITlam,          bit glaExtsBit)
        ,("∷",   ITdcolon,       bit glaExtsBit)
        ,("⇒",   ITdarrow,	bit glaExtsBit)
        ,("∀",	ITforall,	bit glaExtsBit)
        ,("→",   ITrarrow,	bit glaExtsBit)
        ,("←",   ITlarrow,	bit glaExtsBit)
-       ,("?", 	ITdotdot,	bit glaExtsBit)
+       ,("⋯", 	ITdotdot,	bit glaExtsBit)
         -- 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).
@@ -701,13 +700,7 @@ notFollowedBySymbol _ _ _ (AI _ _ buf)
   = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
 
 isNormalComment bits _ _ (AI _ _ buf)
-  | haddockEnabled bits = notFollowedByDocOrPragma
-  | otherwise           = nextCharIs buf (/='#')
-  where 
-    notFollowedByDocOrPragma 
-	= not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
-
-spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
+  = nextCharIs buf (/='#')
 
 haddockDisabledAnd p bits _ _ (AI _ _ buf)
   = if haddockEnabled bits then False else (p buf)
@@ -786,13 +779,12 @@ nested_doc_comment span buf _len = withLexedDocType (go "")
       Just (c,input) -> go (c:commentAcc) input docType False
 
 withLexedDocType lexDocComment = do
-  input <- getInput
-  case alexGetChar input of
-    Nothing -> error "Can't happen"
-    Just ('|', input) -> lexDocComment input ITdocCommentNext False
-    Just ('^', input) -> lexDocComment input ITdocCommentPrev False
-    Just ('$', input) -> lexDocComment input ITdocCommentNamed False
-    Just ('*', input) -> lexDocSection 1 input 
+  input@(AI _ _ buf) <- getInput
+  case prevChar buf ' ' of
+    '|' -> lexDocComment input ITdocCommentNext False
+    '^' -> lexDocComment input ITdocCommentPrev False
+    '$' -> lexDocComment input ITdocCommentNamed False
+    '*' -> lexDocSection 1 input 
  where 
     lexDocSection n input = case alexGetChar input of 
       Just ('*', input) -> lexDocSection (n+1) input
@@ -1299,6 +1291,14 @@ getCharOrFail =  do
 	Just (c,i)  -> do setInput i; return c
 
 -- -----------------------------------------------------------------------------
+-- Warnings
+
+warn :: DynFlag -> SDoc -> Action
+warn option warning span _buf _len = do
+    addWarning option (mkWarnMsg span alwaysQualify warning)
+    lexToken
+
+-- -----------------------------------------------------------------------------
 -- The Parse Monad
 
 data LayoutContext
@@ -1316,6 +1316,8 @@ data ParseResult a
 
 data PState = PState { 
 	buffer	   :: StringBuffer,
+    dflags     :: DynFlags,
+    messages   :: Messages,
         last_loc   :: SrcSpan,	-- pos of previous token
         last_offs  :: !Int, 	-- offset of the previous token from the
 				-- beginning of  the current line.
@@ -1500,6 +1502,10 @@ pragState :: StringBuffer -> SrcLoc -> PState
 pragState buf loc  = 
   PState {
       buffer	      = buf,
+      messages      = emptyMessages,
+      -- XXX defaultDynFlags is not right, but we don't have a real
+      -- dflags handy
+      dflags        = defaultDynFlags,
       last_loc      = mkSrcSpan loc loc,
       last_offs     = 0,
       last_len      = 0,
@@ -1517,6 +1523,8 @@ mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState
 mkPState buf loc flags  = 
   PState {
       buffer	      = buf,
+      dflags        = flags,
+      messages      = emptyMessages,
       last_loc      = mkSrcSpan loc loc,
       last_offs     = 0,
       last_len      = 0,
@@ -1543,6 +1551,15 @@ mkPState buf loc flags  =
       b `setBitIf` cond | cond      = bit b
 			| otherwise = 0
 
+addWarning :: DynFlag -> WarnMsg -> P ()
+addWarning option w
+ = P $ \s@PState{messages=(ws,es), dflags=d} ->
+       let ws' = if dopt option d then ws `snocBag` w else ws
+       in POk s{messages=(ws', es)} ()
+
+getMessages :: PState -> Messages
+getMessages PState{messages=ms} = ms
+
 getContext :: P [LayoutContext]
 getContext = P $ \s@PState{context=ctx} -> POk s ctx