X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHeaderInfo.hs;h=93ce824964ba4e37e65e52095b479e3aea7c71a7;hp=e16c2ce562b07e7b25acd3b274ad06cefe5165b5;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=4917397e279b0aa755eb09e1ca62913237132895

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index e16c2ce..93ce824 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -33,9 +33,9 @@ import Outputable
 import Pretty           ()
 import Maybes
 import Bag		( emptyBag, listToBag, unitBag )
-
-import MonadUtils       ( MonadIO )
+import MonadUtils
 import Exception
+
 import Control.Monad
 import System.IO
 import System.IO.Unsafe
@@ -46,18 +46,17 @@ import Data.List
 -- | Parse the imports of a source file.
 --
 -- Throws a 'SourceError' if parsing fails.
-getImports :: GhcMonad m =>
-              DynFlags
+getImports :: DynFlags
            -> StringBuffer -- ^ Parse this.
            -> FilePath     -- ^ Filename the buffer came from.  Used for
                            --   reporting parse error locations.
            -> FilePath     -- ^ The original source filename (used for locations
                            --   in the function result)
-           -> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
+           -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
               -- ^ The source imports, normal imports, and the module name.
 getImports dflags buf filename source_filename = do
-  let loc  = mkSrcLoc (mkFastString filename) 1 1
-  case unP parseHeader (mkPState buf loc dflags) of
+  let loc  = mkRealSrcLoc (mkFastString filename) 1 1
+  case unP parseHeader (mkPState dflags buf loc) of
     PFailed span err -> parseError span err
     POk pst rdr_module -> do
       let _ms@(_warns, errs) = getMessages pst
@@ -66,7 +65,7 @@ getImports dflags buf filename source_filename = do
           ms = (emptyBag, errs)
       -- logWarnings warns
       if errorsFound dflags ms
-        then liftIO $ throwIO $ mkSrcErr errs
+        then throwIO $ mkSrcErr errs
         else
 	  case rdr_module of
 	    L _ (HsModule mb_mod _ imps _ _ _) ->
@@ -79,7 +78,7 @@ getImports dflags buf filename source_filename = do
 		ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) 
 					ord_idecls
 
-                implicit_prelude = dopt Opt_ImplicitPrelude dflags
+                implicit_prelude = xopt Opt_ImplicitPrelude dflags
                 implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps
 	      in
 	      return (src_idecls, implicit_imports ++ ordinary_imps, mod)
@@ -114,7 +113,7 @@ mkPrelImports this_mod implicit_prelude import_decls
 
       loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")
 
-parseError :: GhcMonad m => SrcSpan -> Message -> m a
+parseError :: SrcSpan -> Message -> IO a
 parseError span err = throwOneError $ mkPlainErrMsg span err
 
 --------------------------------------------------------------
@@ -144,7 +143,7 @@ lazyGetToks dflags filename handle = do
   buf <- hGetStringBufferBlock handle blockSize
   unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
  where
-  loc  = mkSrcLoc (mkFastString filename) 1 1
+  loc  = mkRealSrcLoc (mkFastString filename) 1 1
 
   lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
   lazyLexBuf handle state eof = do
@@ -161,7 +160,7 @@ lazyGetToks dflags filename handle = do
                   _other    -> do rest <- lazyLexBuf handle state' eof
                                   return (t : rest)
       _ | not eof   -> getMore handle state
-        | otherwise -> return [L (last_loc state) ITeof]
+        | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
                          -- parser assumes an ITeof sentinel at the end
 
   getMore :: Handle -> PState -> IO [Located Token]
@@ -176,12 +175,12 @@ lazyGetToks dflags filename handle = do
 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
 getToks dflags filename buf = lexAll (pragState dflags buf loc)
  where
-  loc  = mkSrcLoc (mkFastString filename) 1 1
+  loc  = mkRealSrcLoc (mkFastString filename) 1 1
 
   lexAll state = case unP (lexer return) state of
                    POk _      t@(L _ ITeof) -> [t]
                    POk state' t -> t : lexAll state'
-                   _ -> [L (last_loc state) ITeof]
+                   _ -> [L (RealSrcSpan (last_loc state)) ITeof]
 
 
 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
@@ -228,6 +227,9 @@ getOptions' toks
           parseToks (open:xs)
               | ITlanguage_prag <- getToken open
               = parseLanguage xs
+          parseToks (x:xs)
+              | ITdocCommentNext _ <- getToken x
+              = parseToks xs
           parseToks _ = []
           parseLanguage (L loc (ITconid fs):rest)
               = checkExtension (L loc fs) :
@@ -253,7 +255,7 @@ checkProcessArgsResult flags
       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
     where mkMsg (L loc flag)
               = mkPlainErrMsg loc $
-                  (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
+                  (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
                    text flag)
 
 -----------------------------------------------------------------------------
@@ -263,8 +265,7 @@ checkExtension (L l ext)
 -- Checks if a given extension is valid, and if so returns
 -- its corresponding flag. Otherwise it throws an exception.
  =  let ext' = unpackFS ext in
-    if ext' `elem` supportedLanguages
-       || ext' `elem` (map ("No"++) supportedLanguages)
+    if ext' `elem` supportedLanguagesAndExtensions
     then L l ("-X"++ext')
     else unsupportedExtnError l ext'
 
@@ -281,7 +282,10 @@ unsupportedExtnError :: SrcSpan -> String -> a
 unsupportedExtnError loc unsup =
   throw $ mkSrcErr $ unitBag $
     mkPlainErrMsg loc $
-        text "Unsupported extension: " <> text unsup
+        text "Unsupported extension: " <> text unsup $$
+        if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
+  where
+     suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
 
 
 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
@@ -291,5 +295,5 @@ optionsErrorMsgs unhandled_flags flags_lines _filename
 					  L l f' <- flags_lines, f == f' ]
         mkMsg (L flagSpan flag) = 
             ErrUtils.mkPlainErrMsg flagSpan $
-                    text "unknown flag in  {-# OPTIONS #-} pragma:" <+> text flag
+                    text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag