Add a warning for tabs in source files

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 20edd51..8679ff2 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -46,8 +46,9 @@ import Panic
 import Constants
 import Outputable
 
 import Constants
 import Outputable
 

-import Control.Monad   ( when )
+import Control.Monad

 import Data.Char       ( ord )
 import Data.Char       ( ord )

+import System.Exit

 
 #include "HsVersions.h"
 }
 
 #include "HsVersions.h"
 }

@@ -918,9 +919,12 @@ parseCmmFile dflags filename = do
                -- in there we don't want.
   case unP cmmParse init_state of
     PFailed span err -> do printError span err; return Nothing
                -- in there we don't want.
   case unP cmmParse init_state of
     PFailed span err -> do printError span err; return Nothing

-    POk _ code -> do
+    POk pst code -> do

        cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
        cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))

-       dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
+       let ms = getMessages pst
+       printErrorsAndWarnings dflags ms
+        when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
+        dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])

        return (Just cmm)
   where
        no_module = panic "parseCmmFile: no module"
        return (Just cmm)
   where
        no_module = panic "parseCmmFile: no module"

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index d05b8b2..3e9ca8f 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -156,6 +156,7 @@ data DynFlag
    | Opt_WarnDeprecations
    | Opt_WarnDodgyImports
    | Opt_WarnOrphans
    | Opt_WarnDeprecations
    | Opt_WarnDodgyImports
    | Opt_WarnOrphans

+   | Opt_WarnTabs

 
    -- language opts
    | Opt_AllowOverlappingInstances
 
    -- language opts
    | Opt_AllowOverlappingInstances

@@ -1032,6 +1033,7 @@ fFlags = [
   ( "warn-unused-matches",             Opt_WarnUnusedMatches ),
   ( "warn-deprecations",               Opt_WarnDeprecations ),
   ( "warn-orphans",                    Opt_WarnOrphans ),
   ( "warn-unused-matches",             Opt_WarnUnusedMatches ),
   ( "warn-deprecations",               Opt_WarnDeprecations ),
   ( "warn-orphans",                    Opt_WarnOrphans ),

+  ( "warn-tabs",                       Opt_WarnTabs ),

   ( "fi",                              Opt_FFI ),  -- support `-ffi'...
   ( "ffi",                             Opt_FFI ),  -- ...and also `-fffi'
   ( "arrows",                          Opt_Arrows ), -- arrow syntax
   ( "fi",                              Opt_FFI ),  -- support `-ffi'...
   ( "ffi",                             Opt_FFI ),  -- ...and also `-fffi'
   ( "arrows",                          Opt_Arrows ), -- arrow syntax

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 090af1f..e124e37 100644 (file)
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -15,8 +15,7 @@ module HeaderInfo ( getImportsFromFile, getImports
 #include "HsVersions.h"
 
 import Parser          ( parseHeader )
 #include "HsVersions.h"
 
 import Parser          ( parseHeader )

-import Lexer           ( P(..), ParseResult(..), mkPState, pragState
-                        , lexer, Token(..), PState(..) )
+import Lexer

 import FastString
 import HsSyn           ( ImportDecl(..), HsModule(..) )
 import Module          ( ModuleName, moduleName )
 import FastString
 import HsSyn           ( ImportDecl(..), HsModule(..) )
 import Module          ( ModuleName, moduleName )

@@ -25,7 +24,7 @@ import StringBuffer   ( StringBuffer(..), hGetStringBuffer, hGetStringBufferBlock
                         , appendStringBuffers )
 import SrcLoc
 import FastString      ( mkFastString )
                         , appendStringBuffers )
 import SrcLoc
 import FastString      ( mkFastString )

-import DynFlags        ( DynFlags )
+import DynFlags

 import ErrUtils
 import Util
 import Outputable
 import ErrUtils
 import Util
 import Outputable

@@ -37,6 +36,8 @@ import Bag            ( emptyBag, listToBag )
 import Distribution.Compiler
 
 import Control.Exception
 import Distribution.Compiler
 
 import Control.Exception

+import Control.Monad
+import System.Exit

 import System.IO
 import Data.List
 
 import System.IO
 import Data.List
 

@@ -65,7 +66,10 @@ getImports dflags buf filename = do
   let loc  = mkSrcLoc (mkFastString filename) 1 0
   case unP parseHeader (mkPState buf loc dflags) of
        PFailed span err -> parseError span err
   let loc  = mkSrcLoc (mkFastString filename) 1 0
   case unP parseHeader (mkPState buf loc dflags) of
        PFailed span err -> parseError span err

-       POk _ rdr_module -> 
+       POk pst rdr_module -> do
+          let ms = getMessages pst
+          printErrorsAndWarnings dflags ms
+          when (errorsFound dflags ms) $ exitWith (ExitFailure 1)

          case rdr_module of
            L _ (HsModule mb_mod _ imps _ _ _ _ _) ->
              let
          case rdr_module of
            L _ (HsModule mb_mod _ imps _ _ _ _ _) ->
              let

diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 041ea15..cafba83 100644 (file)
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -54,7 +54,7 @@ import HsSyn          ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
 import SrcLoc          ( Located(..) )
 import StringBuffer    ( hGetStringBuffer, stringToStringBuffer )
 import Parser
 import SrcLoc          ( Located(..) )
 import StringBuffer    ( hGetStringBuffer, stringToStringBuffer )
 import Parser

-import Lexer           ( P(..), ParseResult(..), mkPState )
+import Lexer

 import SrcLoc          ( mkSrcLoc )
 import TcRnDriver      ( tcRnModule, tcRnExtCore )
 import TcIface         ( typecheckIface )
 import SrcLoc          ( mkSrcLoc )
 import TcRnDriver      ( tcRnModule, tcRnExtCore )
 import TcIface         ( typecheckIface )

@@ -93,6 +93,7 @@ import UniqFM         ( emptyUFM )
 import Bag             ( unitBag )
 
 import Control.Monad
 import Bag             ( unitBag )
 
 import Control.Monad

+import System.Exit

 import System.IO
 import Data.IORef
 \end{code}
 import System.IO
 import Data.IORef
 \end{code}

@@ -737,8 +738,12 @@ myParseModule dflags src_filename maybe_src_buf
 
        PFailed span err -> return (Left (mkPlainErrMsg span err));
 
 
        PFailed span err -> return (Left (mkPlainErrMsg span err));
 

-       POk _ rdr_module -> do {
+       POk pst rdr_module -> do {

 
 

+      let {ms = getMessages pst};
+      printErrorsAndWarnings dflags ms;
+      when (errorsFound dflags ms) $ exitWith (ExitFailure 1);
+      

       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
       
       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
       dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
       
       dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"

@@ -893,7 +898,11 @@ hscParseThing parser dflags str
        PFailed span err -> do { printError span err;
                                  return Nothing };
 
        PFailed span err -> do { printError span err;
                                  return Nothing };
 

-       POk _ thing -> do {
+       POk pst thing -> do {
+
+      let {ms = getMessages pst};
+      printErrorsAndWarnings dflags ms;
+      when (errorsFound dflags ms) $ exitWith (ExitFailure 1);

 
       --ToDo: can't free the string buffer until we've finished this
       -- compilation sweep and all the identifiers have gone away.
 
       --ToDo: can't free the string buffer until we've finished this
       -- compilation sweep and all the identifiers have gone away.

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 49dabf0..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,
    Token(..), lexer, pragState, mkPState, PState(..),
    P(..), ParseResult(..), getSrcLoc, 
    failLocMsgP, failSpanMsgP, srcParseFail,

+   getMessages,

    popContext, pushCurrentContext, setLastToken, setSrcLoc,
    getLexState, popLexState, pushLexState,
    extension, glaExtsEnabled, bangPatEnabled
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
    getLexState, popLexState, pushLexState,
    extension, glaExtsEnabled, bangPatEnabled

@@ -32,7 +33,8 @@ module Lexer (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import ErrUtils                ( Message )
+import Bag
+import ErrUtils

 import Outputable
 import StringBuffer
 import FastString
 import Outputable
 import StringBuffer
 import FastString

@@ -43,6 +45,7 @@ import DynFlags
 import Ctype
 import Util            ( maybePrefixMatch, readRational )
 
 import Ctype
 import Util            ( maybePrefixMatch, readRational )
 

+import Control.Monad

 import Data.Bits
 import Data.Char       ( chr, isSpace )
 import Data.Ratio
 import Data.Bits
 import Data.Char       ( chr, isSpace )
 import Data.Ratio

@@ -56,8 +59,9 @@ import Compat.Unicode ( GeneralCategory(..), generalCategory, isPrint, isUpper )
 }
 
 $unispace    = \x05
 }
 
 $unispace    = \x05

-$whitechar   = [\ \t\n\r\f\v\xa0 $unispace]
+$whitechar   = [\ \n\r\f\v\xa0 $unispace]

 $white_no_nl = $whitechar # \n
 $white_no_nl = $whitechar # \n

+$tab         = \t

 
 $ascdigit  = 0-9
 $unidigit  = \x03
 
 $ascdigit  = 0-9
 $unidigit  = \x03

@@ -108,6 +112,7 @@ haskell :-
 
 -- everywhere: skip whitespace and comments
 $white_no_nl+                          ;
 
 -- 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.
 
 -- Everywhere: deal with nested comments.  We explicitly rule out
 -- pragmas, "{-#", so that we don't accidentally treat them as comments.

@@ -1299,6 +1304,14 @@ getCharOrFail =  do
        Just (c,i)  -> do setInput i; return c
 
 -- -----------------------------------------------------------------------------
        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
 -- The Parse Monad
 
 data LayoutContext

@@ -1316,6 +1329,8 @@ data ParseResult a
 
 data PState = PState { 
        buffer     :: StringBuffer,
 
 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.
         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,
 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,
       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,
 mkPState buf loc flags  = 
   PState {
       buffer         = buf,

+      dflags        = flags,
+      messages      = emptyMessages,

       last_loc      = mkSrcSpan loc loc,
       last_offs     = 0,
       last_len      = 0,
       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
 
       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
 
 getContext :: P [LayoutContext]
 getContext = P $ \s@PState{context=ctx} -> POk s ctx
 

diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index a993b42..9c65282 100644 (file)
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -814,6 +814,13 @@
          </row>
 
          <row>
          </row>
 
          <row>

+           <entry><option>-fwarn-tabs</option></entry>
+           <entry>warn if there are tabs in the source file</entry>
+           <entry>dynamic</entry>
+           <entry><option>-fno-warn-tabs</option></entry>
+         </row>
+
+         <row>

            <entry><option>-fwarn-type-defaults</option></entry>
            <entry>warn when defaulting happens</entry>
            <entry>dynamic</entry>
            <entry><option>-fwarn-type-defaults</option></entry>
            <entry>warn when defaulting happens</entry>
            <entry>dynamic</entry>

diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index 0168123..c09fa35 100644 (file)
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -1097,6 +1097,18 @@ f "2"    = 2
       </varlistentry>
 
       <varlistentry>
       </varlistentry>
 
       <varlistentry>

+       <term><option>-fwarn-tabs</option>:</term>
+       <listitem>
+         <indexterm><primary><option>-fwarn-tabs</option></primary></indexterm>
+         <indexterm><primary>tabs, warning</primary></indexterm>
+         <para>Have the compiler warn if there are tabs in your source
+          file.</para>
+
+         <para>This warning is off by default.</para>
+       </listitem>
+      </varlistentry>
+
+      <varlistentry>

        <term><option>-fwarn-type-defaults</option>:</term>
        <listitem>
          <indexterm><primary><option>-fwarn-type-defaults</option></primary></indexterm>
        <term><option>-fwarn-type-defaults</option>:</term>
        <listitem>
          <indexterm><primary><option>-fwarn-type-defaults</option></primary></indexterm>