[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

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

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
 -----------------------------------------------------------------------------

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