[project @ 2005-04-19 15:28:35 by simonmar]

- DriverPipeline.compile: report errors in GHC_OPTIONS pragmas using the
  Message callback, and give them a proper line number.

- GHC.checkModule: read the GHC_OPTIONS pragma, and report errors
  appropriately.

ghc/compiler/main/DriverPipeline.hs

@@ -22,7 +22,8 @@ module DriverPipeline (
         -- DLL building
    doMkDLL,
 
-   getOptionsFromStringBuffer, -- used in module GHC
+   getOptionsFromStringBuffer,	-- used in module GHC
+   optionsErrorMsgs,	  	-- ditto
   ) where
 
 #include "HsVersions.h"
@@ -50,6 +51,9 @@ import Maybes		( expectJust )
 import Ctype		( is_ident )
 import StringBuffer	( StringBuffer(..), lexemeToString )
 import ParserCoreUtils	( getCoreModuleName )
+import SrcLoc		( srcLocSpan, mkSrcLoc )
+import FastString	( mkFastString )
+import Bag		( listToBag, emptyBag )
 
 import EXCEPTION
 import DATA_IOREF	( readIORef, writeIORef, IORef )
@@ -127,8 +131,11 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods
    -- It might be better to cache the flags in the ml_hspp_file field,say
    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
+   (dflags1,unhandled_flags) <- parseDynamicFlags dflags0 (map snd opts)
+   if (not (null unhandled_flags))
+	then do msg_act (optionsErrorMsgs unhandled_flags opts input_fn)
+		return CompErrs
+	else do
 
    let (basename, _) = splitFilename input_fn
 
@@ -1307,22 +1314,22 @@ getOptionsFromSource file
                               return (opts ++ rest)
 		       | otherwise -> return []
 
-getOptionsFromStringBuffer :: StringBuffer -> [String]
+getOptionsFromStringBuffer :: StringBuffer -> [(Int,String)]
 getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) = 
   let 
 	ls = lines (lexemeToString buffer (I# len#))  -- lazy, so it's ok
   in
-  look ls
+  look 1 ls
   where
-	look [] = []
-	look (l':ls) = do
+	look i [] = []
+	look i (l':ls) = do
 	    let l = removeSpaces l'
 	    case () of
-		() | null l -> look ls
-		   | prefixMatch "#" l -> look ls
-		   | prefixMatch "{-# LINE" l -> look ls   -- -}
+		() | null l -> look (i+1) ls
+		   | prefixMatch "#" l -> look (i+1) ls
+		   | prefixMatch "{-# LINE" l -> look (i+1) ls   -- -}
 		   | Just opts <- matchOptions l
-			-> opts ++ look ls
+			-> zip (repeat i) opts ++ look (i+1) ls
 		   | otherwise -> []
 
 -- detect {-# OPTIONS_GHC ... #-}.  For the time being, we accept OPTIONS
@@ -1351,6 +1358,19 @@ matchOptions s
     | otherwise = Nothing
 
 
+optionsErrorMsgs :: [String] -> [(Int,String)] -> FilePath -> Messages
+optionsErrorMsgs unhandled_flags flags_lines filename
+  = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
+  where
+	unhandled_flags_lines = [ (l,f) | f <- unhandled_flags, 
+					  (l,f') <- flags_lines, f == f' ]
+	mkMsg (line,flag) = 
+	    ErrUtils.mkPlainErrMsg (srcLocSpan loc) $
+		text "unknown flag in  {-# OPTIONS #-} pragma:" <+> text flag
+	  where
+		loc = mkSrcLoc (mkFastString filename) line 0
+		-- ToDo: we need a better SrcSpan here
+
 -- -----------------------------------------------------------------------------
 -- Misc.
 

ghc/compiler/main/GHC.hs

@@ -155,7 +155,7 @@ import DataCon		( DataCon )
 import Name		( Name, getName, nameModule_maybe )
 import RdrName		( RdrName, gre_name, globalRdrEnvElts )
 import NameEnv		( nameEnvElts )
-import SrcLoc		( Located(..) )
+import SrcLoc		( Located(..), mkSrcLoc, srcLocSpan )
 import DriverPipeline
 import DriverPhases	( Phase(..), isHaskellSrcFilename, startPhase )
 import GetImports	( getImports )
@@ -179,6 +179,8 @@ import SysTools		( cleanTempFilesExcept )
 import BasicTypes	( SuccessFlag(..), succeeded, failed )
 import Maybes		( orElse, expectJust, mapCatMaybes )
 import TcType           ( tcSplitSigmaTy, isDictTy )
+import Bag		( unitBag, emptyBag )
+import FastString	( mkFastString )
 
 import Directory        ( getModificationTime, doesFileExist )
 import Maybe		( isJust, isNothing, fromJust, fromMaybe, catMaybes )
@@ -652,7 +654,21 @@ checkModule session@(Session ref) mod msg_act = do
    case [ ms | ms <- mg, ms_mod ms == mod ] of
 	[] -> return Nothing
 	(ms:_) -> do 
-	   r <- hscFileCheck hsc_env msg_act ms
+	   -- 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
+	   let dflags0 = hsc_dflags hsc_env
+	       hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms)
+	       opts = getOptionsFromStringBuffer hspp_buf
+	   (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts)
+	   if (not (null leftovers))
+		then do let filename = fromJust (ml_hs_file (ms_location ms))
+			msg_act (optionsErrorMsgs leftovers opts filename)
+		        return Nothing
+		else do
+
+	   r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms
 	   case r of
 		HscFail -> 
 		   return Nothing
@@ -1398,7 +1414,7 @@ preprocessFile dflags src_fn (Just (buf, time))
 	let 
 	    local_opts = getOptionsFromStringBuffer buf
 	--
-	(dflags', errs) <- parseDynamicFlags dflags local_opts
+	(dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
 
 	let
 	    needs_preprocessing