Refactor SrcLoc and SrcSpan

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

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index b520098..93ce824 100644 (file)
--- 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,7 +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
+    if ext' `elem` supportedLanguagesAndExtensions
     then L l ("-X"++ext')
     else unsupportedExtnError l ext'
 
@@ -282,7 +284,8 @@ unsupportedExtnError loc unsup =
     mkPlainErrMsg loc $
         text "Unsupported extension: " <> text unsup $$
         if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
-  where suggestions = fuzzyMatch unsup supportedLanguages
+  where
+     suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
 
 
 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
@@ -292,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