Give locations of flag warnings/errors

[ghc-hetmet.git] / compiler / main / HeaderInfo.hs

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index a9e2051..22f645e 100644 (file)
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -17,7 +17,8 @@
 
 module HeaderInfo ( getImports
                   , getOptionsFromFile, getOptions
-                  , optionsErrorMsgs ) where
+                  , optionsErrorMsgs,
+                    checkProcessArgsResult ) where
 
 #include "HsVersions.h"
 
@@ -39,23 +40,12 @@ import Panic
 import Maybes
 import Bag             ( emptyBag, listToBag )
 
-import Control.Exception
+import Exception
 import Control.Monad
 import System.Exit
 import System.IO
 import Data.List
 
-#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 601
-  -- already imported above
---import System.IO             ( openBinaryFile )
-#else
-import IOExts                   ( openFileEx, IOModeEx(..) )
-#endif
-
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
-openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
-#endif
-
 getImports :: DynFlags -> StringBuffer -> FilePath -> FilePath
     -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName)
 getImports dflags buf filename source_filename = do
@@ -71,8 +61,9 @@ getImports dflags buf filename source_filename = do
              let
                 main_loc = mkSrcLoc (mkFastString source_filename) 1 0
                mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
-               (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
-               source_imps   = map getImpMod src_idecls        
+                imps' = filter isHomeImp (map unLoc imps)
+               (src_idecls, ord_idecls) = partition isSourceIdecl imps'
+               source_imps   = map getImpMod src_idecls
                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc) 
                                        (map getImpMod ord_idecls)
                     -- GHC.Prim doesn't exist physically, so don't go looking for it.
@@ -80,23 +71,29 @@ getImports dflags buf filename source_filename = do
              return (source_imps, ordinary_imps, mod)
   
 parseError :: SrcSpan -> Message -> a
-parseError span err = throwDyn $ mkPlainErrMsg span err
+parseError span err = throwErrMsg $ mkPlainErrMsg span err
+
+-- we aren't interested in package imports here, filter them out
+isHomeImp :: ImportDecl name -> Bool
+isHomeImp (ImportDecl _ (Just p) _ _ _ _) = p == fsLit "this"
+isHomeImp (ImportDecl _ Nothing  _ _ _ _) = True
 
 isSourceIdecl :: ImportDecl name -> Bool
-isSourceIdecl (ImportDecl _ s _ _ _) = s
+isSourceIdecl (ImportDecl _ _ s _ _ _) = s
 
 getImpMod :: ImportDecl name -> Located ModuleName
-getImpMod (ImportDecl located_mod _ _ _ _) = located_mod
+getImpMod (ImportDecl located_mod _ _ _ _ _) = located_mod
 
 --------------------------------------------------------------
 -- Get options
 --------------------------------------------------------------
 
 
-getOptionsFromFile :: FilePath            -- input file
+getOptionsFromFile :: DynFlags
+                   -> FilePath            -- input file
                    -> IO [Located String] -- options, if any
-getOptionsFromFile filename
-    = Control.Exception.bracket
+getOptionsFromFile dflags filename
+    = Exception.bracket
              (openBinaryFile filename ReadMode)
               (hClose)
               (\handle ->
@@ -106,7 +103,7 @@ getOptionsFromFile filename
           loop handle buf
               | len buf == 0 = return []
               | otherwise
-              = case getOptions' buf filename of
+              = case getOptions' dflags buf filename of
                   (Nothing, opts) -> return opts
                   (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
                                           newBuf <- appendStringBuffers buf' nextBlock
@@ -115,22 +112,23 @@ getOptionsFromFile filename
                                              else do opts' <- loop handle newBuf
                                                      return (opts++opts')
 
-getOptions :: StringBuffer -> FilePath -> [Located String]
-getOptions buf filename
-    = case getOptions' buf filename of
+getOptions :: DynFlags -> StringBuffer -> FilePath -> [Located String]
+getOptions dflags buf filename
+    = case getOptions' dflags buf filename of
         (_,opts) -> opts
 
 -- The token parser is written manually because Happy can't
 -- return a partial result when it encounters a lexer error.
 -- We want to extract options before the buffer is passed through
 -- CPP, so we can't use the same trick as 'getImports'.
-getOptions' :: StringBuffer         -- Input buffer
+getOptions' :: DynFlags
+            -> StringBuffer         -- Input buffer
             -> FilePath             -- Source file. Used for msgs only.
             -> ( Maybe StringBuffer -- Just => we can use more input
                , [Located String]   -- Options.
                )
-getOptions' buf filename
-    = parseToks (lexAll (pragState buf loc))
+getOptions' dflags buf filename
+    = parseToks (lexAll (pragState dflags buf loc))
     where loc  = mkSrcLoc (mkFastString filename) 1 0
 
           getToken (_buf,L _loc tok) = tok
@@ -184,6 +182,20 @@ getOptions' buf filename
                            POk state' t -> (buffer state,t):lexAll state'
                            _ -> [(buffer state,L (last_loc state) ITeof)]
 
+-----------------------------------------------------------------------------
+-- Complain about non-dynamic flags in OPTIONS pragmas
+
+checkProcessArgsResult :: [Located String] -> IO ()
+checkProcessArgsResult flags
+  = when (notNull flags) $
+        ghcError $ ProgramError $ showSDoc $ vcat $ map f flags
+    where f (L loc flag)
+              = hang (ppr loc <> char ':') 4
+                     (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
+                      text flag)
+
+-----------------------------------------------------------------------------
+
 checkExtension :: Located FastString -> Located String
 checkExtension (L l ext)
 -- Checks if a given extension is valid, and if so returns