[project @ 2005-03-31 16:11:49 by simonmar]

DriverPipeline.compile: we should be grabbing the OPTIONS from the
StringBuffer, not reading the file again (duh!)

SysTools: some message cleanups

diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index 42797ac..fae03ac 100644 (file)
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -22,7 +22,7 @@ module DriverPipeline (
         -- DLL building
    doMkDLL,
 
-   matchOptions, -- used in module GHC
+   getOptionsFromStringBuffer, -- used in module GHC
   ) where
 
 #include "HsVersions.h"
@@ -48,11 +48,12 @@ import StringBuffer ( hGetStringBuffer )
 import BasicTypes      ( SuccessFlag(..) )
 import Maybes          ( expectJust )
 import Ctype           ( is_ident )
-
-import ParserCoreUtils ( getCoreModuleName )
+import StringBuffer    ( StringBuffer(..), lexemeToString )
+import ParserCoreUtils ( getCoreModuleName )
 
 import EXCEPTION
 import DATA_IOREF      ( readIORef, writeIORef, IORef )
+import GLAEXTS         ( Int(..) )
 
 import Directory
 import System
@@ -118,12 +119,13 @@ compile hsc_env mod_summary maybe_old_linkable old_iface = do
    let input_fn   = expectJust "compile:hs" (ml_hs_file location) 
    let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary)
 
-   when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
+   when (verb >= 2) (putMsg ("compile: input file " ++ input_fnpp))
 
    -- Add in the OPTIONS from the source file
    -- This is nasty: we've done this once already, in the compilation manager
    -- It might be better to cache the flags in the ml_hspp_file field,say
-   opts <- getOptionsFromSource input_fnpp
+   let hspp_buf = expectJust "compile:hspp_buf" (ms_hspp_buf mod_summary)
+       opts = getOptionsFromStringBuffer hspp_buf
    (dflags1,unhandled_flags) <- parseDynamicFlags dflags0 opts
    checkProcessArgsResult unhandled_flags input_fn
 
@@ -248,6 +250,9 @@ link Interactive dflags batch_attempt_linking hpt
         return Succeeded
 #endif
 
+link JustTypecheck dflags batch_attempt_linking hpt
+   = return Succeeded
+
 link BatchCompile dflags batch_attempt_linking hpt
    | batch_attempt_linking
    = do 
@@ -1305,6 +1310,24 @@ getOptionsFromSource file
                               return (opts ++ rest)
                       | otherwise -> return []
 
+getOptionsFromStringBuffer :: StringBuffer -> [String]
+getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) = 
+  let 
+       ls = lines (lexemeToString buffer (I# len#))  -- lazy, so it's ok
+  in
+  look ls
+  where
+       look [] = []
+       look (l':ls) = do
+           let l = removeSpaces l'
+           case () of
+               () | null l -> look ls
+                  | prefixMatch "#" l -> look ls
+                  | prefixMatch "{-# LINE" l -> look ls   -- -}
+                  | Just opts <- matchOptions l
+                       -> opts ++ look ls
+                  | otherwise -> []
+
 -- detect {-# OPTIONS_GHC ... #-}.  For the time being, we accept OPTIONS
 -- instead of OPTIONS_GHC, but that is deprecated.
 matchOptions s

diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs
index 3214a41..89b600b 100644 (file)
--- a/ghc/compiler/main/GHC.hs
+++ b/ghc/compiler/main/GHC.hs
@@ -122,10 +122,10 @@ import Module
 import FiniteMap
 import Panic
 import Digraph
-import ErrUtils                ( showPass, Messages )
+import ErrUtils                ( showPass, Messages, putMsg )
 import qualified ErrUtils
 import Util
-import StringBuffer    ( StringBuffer(..), hGetStringBuffer, lexemeToString )
+import StringBuffer    ( StringBuffer, hGetStringBuffer )
 import Outputable
 import SysTools                ( cleanTempFilesExcept )
 import BasicTypes      ( SuccessFlag(..), succeeded, failed )
@@ -140,7 +140,6 @@ import Monad                ( unless, when, foldM )
 import System          ( exitWith, ExitCode(..) )
 import Time            ( ClockTime )
 import EXCEPTION as Exception hiding (handle)
-import GLAEXTS         ( Int(..) )
 import DATA_IOREF
 import IO
 import Prelude hiding (init)
@@ -480,8 +479,7 @@ load s@(Session ref) how_much
 
          then 
            -- Easy; just relink it all.
-           do when (verb >= 2) $ 
-                hPutStrLn stderr "Upsweep completely successful."
+           do when (verb >= 2) $ putMsg "Upsweep completely successful."
 
              -- Clean up after ourselves
              cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
@@ -504,7 +502,7 @@ load s@(Session ref) how_much
 
              when (ghci_mode == BatchCompile && isJust ofile && not do_linking
                     && verb > 0) $
-                hPutStrLn stderr ("Warning: output was redirected with -o, " ++
+                       putMsg ("Warning: output was redirected with -o, " ++
                                   "but no output will be generated\n" ++
                                   "because there is no " ++ main_mod ++ " module.")
 
@@ -517,8 +515,7 @@ load s@(Session ref) how_much
            -- Tricky.  We need to back out the effects of compiling any
            -- half-done cycles, both so as to clean up the top level envs
            -- and to avoid telling the interactive linker to link them.
-           do when (verb >= 2) $
-               hPutStrLn stderr "Upsweep partially successful."
+           do when (verb >= 2) $ putMsg "Upsweep partially successful."
 
               let modsDone_names
                      = map ms_mod modsDone
@@ -613,7 +610,8 @@ checkModule session@(Session ref) mod msg_act = do
 unload :: HscEnv -> [Linkable] -> IO ()
 unload hsc_env stable_linkables        -- Unload everthing *except* 'stable_linkables'
   = case ghcMode (hsc_dflags hsc_env) of
-       BatchCompile -> return ()
+       BatchCompile  -> return ()
+       JustTypecheck -> return ()
 #ifdef GHCI
        Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
 #else
@@ -1335,25 +1333,6 @@ preprocessFile dflags src_fn (Just (buf, time))
        return (dflags', "<buffer>", buf)
 
 
--- code adapted from the file-based version in DriverUtil
-getOptionsFromStringBuffer :: StringBuffer -> [String]
-getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) = 
-  let 
-       ls = lines (lexemeToString buffer (I# len#))  -- lazy, so it's ok
-  in
-  look ls
-  where
-       look [] = []
-       look (l':ls) = do
-           let l = removeSpaces l'
-           case () of
-               () | null l -> look ls
-                  | prefixMatch "#" l -> look ls
-                  | prefixMatch "{-# LINE" l -> look ls   -- -}
-                  | Just opts <- matchOptions l
-                       -> opts ++ look ls
-                  | otherwise -> []
-
 -----------------------------------------------------------------------------
 --                     Error messages
 -----------------------------------------------------------------------------

diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index d919bcf..1033f6a 100644 (file)
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -47,6 +47,7 @@ module SysTools (
 import DriverPhases     ( isHaskellUserSrcFilename )
 import Config
 import Outputable
+import ErrUtils                ( putMsg )
 import Panic           ( GhcException(..) )
 import Util            ( Suffix, global, notNull, consIORef,
                          normalisePath, pgmPath, platformPath )
@@ -621,8 +622,8 @@ traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
 -- b) don't do it at all if dry-run is set
 traceCmd dflags phase_name cmd_line action
  = do  { let verb = verbosity dflags
-       ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
-       ; when (verb >= 3) $ hPutStrLn stderr cmd_line
+       ; when (verb >= 2) $ putMsg ("*** " ++ phase_name)
+       ; when (verb >= 3) $ putMsg cmd_line
        ; hFlush stderr
        
           -- Test for -n flag