Add a warning for tabs in source files

[ghc-hetmet.git] / compiler / parser / Lexer.x

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 6a25ae5..4238938 100644 (file)
--- 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.
@@ -233,6 +238,8 @@ $white_no_nl+                               ;
   "{-#" $whitechar* (DEPRECATED|deprecated)
                                        { token ITdeprecated_prag }
   "{-#" $whitechar* (SCC|scc)          { token ITscc_prag }
+  "{-#" $whitechar* (GENERATED|generated)
+                                       { token ITgenerated_prag }
   "{-#" $whitechar* (CORE|core)                { token ITcore_prag }
   "{-#" $whitechar* (UNPACK|unpack)    { token ITunpack_prag }
 
@@ -387,9 +394,9 @@ data Token
   | ITdata
   | ITdefault
   | ITderiving
+  | ITderive
   | ITdo
   | ITelse
-  | ITfor
   | IThiding
   | ITif
   | ITimport
@@ -420,7 +427,6 @@ data Token
   | ITccallconv
   | ITdotnet
   | ITmdo
-  | ITiso
   | ITfamily
 
        -- Pragmas
@@ -432,6 +438,7 @@ data Token
   | ITdeprecated_prag
   | ITline_prag
   | ITscc_prag
+  | ITgenerated_prag
   | ITcore_prag                 -- hdaume: core annotations
   | ITunpack_prag
   | ITclose_prag
@@ -541,7 +548,7 @@ isSpecial :: Token -> Bool
 -- not as a keyword.
 isSpecial ITas         = True
 isSpecial IThiding     = True
-isSpecial ITfor        = True
+isSpecial ITderive     = True
 isSpecial ITqualified  = True
 isSpecial ITforall     = True
 isSpecial ITexport     = True
@@ -553,7 +560,6 @@ isSpecial ITunsafe          = True
 isSpecial ITccallconv   = True
 isSpecial ITstdcallconv = True
 isSpecial ITmdo                = True
-isSpecial ITiso                = True
 isSpecial ITfamily     = True
 isSpecial _             = False
 
@@ -573,9 +579,9 @@ reservedWordsFM = listToUFM $
        ( "data",       ITdata,         0 ),     
        ( "default",    ITdefault,      0 ),  
        ( "deriving",   ITderiving,     0 ), 
+       ( "derive",     ITderive,       0 ), 
        ( "do",         ITdo,           0 ),       
        ( "else",       ITelse,         0 ),     
-       ( "for",        ITfor,          0 ),
        ( "hiding",     IThiding,       0 ),
        ( "if",         ITif,           0 ),       
        ( "import",     ITimport,       0 ),   
@@ -646,7 +652,7 @@ reservedSymsFM = listToUFM $
        ,("∀",        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).
@@ -690,24 +696,23 @@ pop _span _buf _len = do popLexState; lexToken
 pop_and :: Action -> Action
 pop_and act span buf len = do popLexState; act span buf len
 
-notFollowedBy char _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf /= char
+{-# INLINE nextCharIs #-}
+nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
+
+notFollowedBy char _ _ _ (AI _ _ buf) 
+  = nextCharIs buf (/=char)
 
 notFollowedBySymbol _ _ _ (AI _ _ buf)
-  = atEnd buf || currentChar buf `notElem` "!#$%&*+./<=>?@\\^|-~"
+  = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
 
 isNormalComment bits _ _ (AI _ _ buf)
-  = (if haddockEnabled bits then False else (followedBySpaceDoc buf))
-    || notFollowedByDocOrPragma
+  | haddockEnabled bits = notFollowedByDocOrPragma
+  | otherwise           = nextCharIs buf (/='#')
   where 
-    notFollowedByDocOrPragma = not $ spaceAndP buf
-      (\buf' -> currentChar buf' `elem` "|^*$#")
-
-spaceAndP buf p = p buf || currentChar buf == ' ' && p buf'
-  where buf' = snd (nextChar buf)
+    notFollowedByDocOrPragma 
+       = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
 
-followedBySpaceDoc buf = spaceAndP buf followedByDoc
-
-followedByDoc buf = currentChar buf `elem` "|^*$"
+spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
 
 haddockDisabledAnd p bits _ _ (AI _ _ buf)
   = if haddockEnabled bits then False else (p buf)
@@ -1299,6 +1304,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 +1329,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 +1515,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 +1536,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 +1564,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