Another round of External Core fixes

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

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index ee2cde8..a9e2051 100644 (file)
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -1,3 +1,10 @@
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 -----------------------------------------------------------------------------
 --
 -- Parsing the top of a Haskell source file to get its module name,
@@ -8,13 +15,6 @@
 --
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
 module HeaderInfo ( getImports
                   , getOptionsFromFile, getOptions
                   , optionsErrorMsgs ) where
@@ -27,9 +27,8 @@ import FastString
 import HsSyn           ( ImportDecl(..), HsModule(..) )
 import Module          ( ModuleName, moduleName )
 import PrelNames        ( gHC_PRIM, mAIN_NAME )
-import StringBuffer    ( StringBuffer(..), hGetStringBuffer, hGetStringBufferBlock
+import StringBuffer    ( StringBuffer(..), hGetStringBufferBlock
                         , appendStringBuffers )
-import Config
 import SrcLoc
 import DynFlags
 import ErrUtils
@@ -46,13 +45,14 @@ import System.Exit
 import System.IO
 import Data.List
 
-#if __GLASGOW_HASKELL__ >= 601
-import System.IO               ( openBinaryFile )
+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ >= 601
+  -- already imported above
+--import System.IO             ( openBinaryFile )
 #else
 import IOExts                   ( openFileEx, IOModeEx(..) )
 #endif
 
-#if __GLASGOW_HASKELL__ < 601
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 601
 openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
 #endif
 
@@ -67,7 +67,7 @@ getImports dflags buf filename source_filename = do
           printErrorsAndWarnings dflags ms
           when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
          case rdr_module of
-           L _ (HsModule mb_mod _ imps _ _ _ _ _) ->
+           L _ (HsModule mb_mod _ imps _ _ _ _) ->
              let
                 main_loc = mkSrcLoc (mkFastString source_filename) 1 0
                mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
@@ -79,10 +79,13 @@ getImports dflags buf filename source_filename = do
              in
              return (source_imps, ordinary_imps, mod)
   
+parseError :: SrcSpan -> Message -> a
 parseError span err = throwDyn $ mkPlainErrMsg span err
 
+isSourceIdecl :: ImportDecl name -> Bool
 isSourceIdecl (ImportDecl _ s _ _ _) = s
 
+getImpMod :: ImportDecl name -> Located ModuleName
 getImpMod (ImportDecl located_mod _ _ _ _) = located_mod
 
 --------------------------------------------------------------
@@ -130,8 +133,8 @@ getOptions' buf filename
     = parseToks (lexAll (pragState buf loc))
     where loc  = mkSrcLoc (mkFastString filename) 1 0
 
-          getToken (buf,L _loc tok) = tok
-          getLoc (buf,L loc _tok) = loc
+          getToken (_buf,L _loc tok) = tok
+          getLoc (_buf,L loc _tok) = loc
           getBuf (buf,_tok) = buf
           combine opts (flag, opts') = (flag, opts++opts')
           add opt (flag, opts) = (flag, opt:opts)
@@ -146,6 +149,15 @@ getOptions' buf filename
               , ITclose_prag       <- getToken close
               = map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
                 parseToks xs
+          parseToks (open:close:xs)
+              | ITdocOptions str <- getToken open
+              , ITclose_prag     <- getToken close
+              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
+                `combine` parseToks xs
+          parseToks (open:xs)
+              | ITdocOptionsOld str <- getToken open
+              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
+                `combine` parseToks xs
           parseToks (open:xs)
               | ITlanguage_prag <- getToken open
               = parseLanguage xs
@@ -161,14 +173,14 @@ getOptions' buf filename
           parseLanguage ((_buf,L loc (ITconid fs)):rest)
               = checkExtension (L loc fs) `add`
                 case rest of
-                  (_,L loc ITcomma):more -> parseLanguage more
-                  (_,L loc ITclose_prag):more -> parseToks more
+                  (_,L _loc ITcomma):more -> parseLanguage more
+                  (_,L _loc ITclose_prag):more -> parseToks more
                   (_,L loc _):_ -> languagePragParseError loc
           parseLanguage (tok:_)
               = languagePragParseError (getLoc tok)
           lexToken t = return t
           lexAll state = case unP (lexer lexToken) state of
-                           POk state' t@(L _ ITeof) -> [(buffer state,t)]
+                           POk _      t@(L _ ITeof) -> [(buffer state,t)]
                            POk state' t -> (buffer state,t):lexAll state'
                            _ -> [(buffer state,L (last_loc state) ITeof)]
 
@@ -182,10 +194,13 @@ checkExtension (L l ext)
     then L l ("-X"++ext')
     else unsupportedExtnError l ext'
 
+languagePragParseError :: SrcSpan -> a
 languagePragParseError loc =
-  pgmError (showSDoc (mkLocMessage loc (
-                text "cannot parse LANGUAGE pragma")))
+  pgmError 
+   (showSDoc (mkLocMessage loc (
+     text "cannot parse LANGUAGE pragma: comma-separated list expected")))
 
+unsupportedExtnError :: SrcSpan -> String -> a
 unsupportedExtnError loc unsup =
   pgmError (showSDoc (mkLocMessage loc (
                 text "unsupported extension: " <>
@@ -193,7 +208,7 @@ unsupportedExtnError loc unsup =
 
 
 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
-optionsErrorMsgs unhandled_flags flags_lines filename
+optionsErrorMsgs unhandled_flags flags_lines _filename
   = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
   where        unhandled_flags_lines = [ L l f | f <- unhandled_flags, 
                                          L l f' <- flags_lines, f == f' ]