Add some commented-out tracing in SpecConstr
[ghc.git] / compiler / main / HeaderInfo.hs
index f7ae35f..6dd16f6 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 -----------------------------------------------------------------------------
 --
 -- | Parsing the top of a Haskell source file to get its module name,
@@ -8,13 +10,6 @@
 --
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module HeaderInfo ( getImports
                   , mkPrelImports -- used by the renamer too
                   , getOptionsFromFile, getOptions
@@ -25,7 +20,7 @@ module HeaderInfo ( getImports
 
 import RdrName
 import HscTypes
-import Parser          ( parseHeader )
+import Parser           ( parseHeader )
 import Lexer
 import FastString
 import HsSyn
@@ -39,9 +34,11 @@ import Util
 import Outputable
 import Pretty           ()
 import Maybes
-import Bag             ( emptyBag, listToBag, unitBag )
+import Bag              ( emptyBag, listToBag, unitBag )
 import MonadUtils
 import Exception
+import BasicTypes
+import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import System.IO
@@ -59,14 +56,16 @@ getImports :: DynFlags
                            --   reporting parse error locations.
            -> FilePath     -- ^ The original source filename (used for locations
                            --   in the function result)
-           -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
+           -> IO ([(Maybe FastString, Located ModuleName)],
+                  [(Maybe FastString, Located ModuleName)],
+                  Located ModuleName)
               -- ^ The source imports, normal imports, and the module name.
 getImports dflags buf filename source_filename = do
   let loc  = mkRealSrcLoc (mkFastString filename) 1 1
   case unP parseHeader (mkPState dflags buf loc) of
     PFailed span err -> parseError dflags span err
     POk pst rdr_module -> do
-      let _ms@(_warns, errs) = getMessages pst
+      let _ms@(_warns, errs) = getMessages pst dflags
       -- don't log warnings: they'll be reported when we parse the file
       -- for real.  See #2500.
           ms = (emptyBag, errs)
@@ -74,27 +73,33 @@ getImports dflags buf filename source_filename = do
       if errorsFound dflags ms
         then throwIO $ mkSrcErr errs
         else
-         case rdr_module of
-           L _ (HsModule mb_mod _ imps _ _ _) ->
-             let
+          case rdr_module of
+            L _ hsmod ->
+              let
+                mb_mod = hsmodName hsmod
+                imps = hsmodImports hsmod
                 main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1)
-               mod = mb_mod `orElse` L main_loc mAIN_NAME
-               (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
-
-                    -- GHC.Prim doesn't exist physically, so don't go looking for it.
-               ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) 
-                                       ord_idecls
-
-                implicit_prelude = xopt Opt_ImplicitPrelude dflags
-                implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps
-             in
-             return (src_idecls, implicit_imports ++ ordinary_imps, mod)
-
-mkPrelImports :: ModuleName 
+                mod = mb_mod `orElse` L main_loc mAIN_NAME
+                (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
+
+                     -- GHC.Prim doesn't exist physically, so don't go looking for it.
+                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
+                                       ord_idecls
+
+                implicit_prelude = xopt LangExt.ImplicitPrelude dflags
+                implicit_imports = mkPrelImports (unLoc mod) main_loc
+                                                 implicit_prelude imps
+                convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
+              in
+              return (map convImport src_idecls,
+                      map convImport (implicit_imports ++ ordinary_imps),
+                      mod)
+
+mkPrelImports :: ModuleName
               -> SrcSpan    -- Attribute the "import Prelude" to this location
               -> Bool -> [LImportDecl RdrName]
               -> [LImportDecl RdrName]
--- Consruct the implicit declaration "import Prelude" (or not)
+-- Construct the implicit declaration "import Prelude" (or not)
 --
 -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
 -- because the former doesn't even look at Prelude.hi for instance
@@ -108,20 +113,21 @@ mkPrelImports this_mod loc implicit_prelude import_decls
   where
       explicit_prelude_import
        = notNull [ () | L _ (ImportDecl { ideclName = mod
-                                        , ideclPkgQual = Nothing }) 
+                                        , ideclPkgQual = Nothing })
                           <- import_decls
-                     , unLoc mod == pRELUDE_NAME ]
+                      , unLoc mod == pRELUDE_NAME ]
 
       preludeImportDecl :: LImportDecl RdrName
       preludeImportDecl
-        = L loc $ ImportDecl { ideclName      = L loc pRELUDE_NAME,
-                              ideclPkgQual   = Nothing,
-                              ideclSource    = False,
-                              ideclSafe      = False,  -- Not a safe import
-                              ideclQualified = False,
-                              ideclImplicit  = True,   -- Implicit!
-                              ideclAs        = Nothing,
-                              ideclHiding    = Nothing  }
+        = L loc $ ImportDecl { ideclSourceSrc = NoSourceText,
+                               ideclName      = L loc pRELUDE_NAME,
+                               ideclPkgQual   = Nothing,
+                               ideclSource    = False,
+                               ideclSafe      = False,  -- Not a safe import
+                               ideclQualified = False,
+                               ideclImplicit  = True,   -- Implicit!
+                               ideclAs        = Nothing,
+                               ideclHiding    = Nothing  }
 
 parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a
 parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err
@@ -138,7 +144,7 @@ getOptionsFromFile :: DynFlags
                    -> IO [Located String] -- ^ Parsed options, if any.
 getOptionsFromFile dflags filename
     = Exception.bracket
-             (openBinaryFile filename ReadMode)
+              (openBinaryFile filename ReadMode)
               (hClose)
               (\handle -> do
                   opts <- fmap (getOptions' dflags)
@@ -167,7 +173,7 @@ lazyGetToks dflags filename handle = do
 
   lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
   lazyLexBuf handle state eof size = do
-    case unP (lexer return) state of
+    case unP (lexer False return) state of
       POk state' t -> do
         -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
         if atEnd (buffer state') && not eof
@@ -192,8 +198,8 @@ lazyGetToks dflags filename handle = do
        -- large module names (#5981)
      nextbuf <- hGetStringBufferBlock handle new_size
      if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
-     newbuf <- appendStringBuffers (buffer state) nextbuf
-     unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size
+       newbuf <- appendStringBuffers (buffer state) nextbuf
+       unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size
 
 
 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
@@ -201,7 +207,7 @@ getToks dflags filename buf = lexAll (pragState dflags buf loc)
  where
   loc  = mkRealSrcLoc (mkFastString filename) 1 1
 
-  lexAll state = case unP (lexer return) state of
+  lexAll state = case unP (lexer False return) state of
                    POk _      t@(L _ ITeof) -> [t]
                    POk state' t -> t : lexAll state'
                    _ -> [L (RealSrcSpan (last_loc state)) ITeof]
@@ -226,15 +232,16 @@ getOptions' :: DynFlags
             -> [Located String]     -- Options.
 getOptions' dflags toks
     = parseToks toks
-    where 
+    where
           getToken (L _loc tok) = tok
           getLoc (L loc _tok) = loc
 
           parseToks (open:close:xs)
               | IToptions_prag str <- getToken open
               , ITclose_prag       <- getToken close
-              = map (L (getLoc open)) (words str) ++
-                parseToks xs
+              = case toArgs str of
+                  Left err -> panic ("getOptions'.parseToks: " ++ err)
+                  Right args -> map (L (getLoc open)) args ++ parseToks xs
           parseToks (open:close:xs)
               | ITinclude_prag str <- getToken open
               , ITclose_prag       <- getToken close
@@ -246,12 +253,11 @@ getOptions' dflags toks
               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
                 ++ parseToks xs
           parseToks (open:xs)
-              | ITdocOptionsOld str <- getToken open
-              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
-                ++ parseToks xs
-          parseToks (open:xs)
               | ITlanguage_prag <- getToken open
               = parseLanguage xs
+          parseToks (comment:xs) -- Skip over comments
+              | isComment (getToken comment)
+              = parseToks xs
           parseToks _ = []
           parseLanguage (L loc (ITconid fs):rest)
               = checkExtension dflags (L loc fs) :
@@ -265,6 +271,17 @@ getOptions' dflags toks
           parseLanguage []
               = panic "getOptions'.parseLanguage(2) went past eof token"
 
+          isComment :: Token -> Bool
+          isComment c =
+            case c of
+              (ITlineComment {})     -> True
+              (ITblockComment {})    -> True
+              (ITdocCommentNext {})  -> True
+              (ITdocCommentPrev {})  -> True
+              (ITdocCommentNamed {}) -> True
+              (ITdocSection {})      -> True
+              _                      -> False
+
 -----------------------------------------------------------------------------
 
 -- | Complain about non-dynamic flags in OPTIONS pragmas.
@@ -298,14 +315,14 @@ languagePragParseError dflags loc =
        vcat [ text "Cannot parse LANGUAGE pragma"
             , text "Expecting comma-separated list of language options,"
             , text "each starting with a capital letter"
-            , nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ])
+            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ])
 
 unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
 unsupportedExtnError dflags loc unsup =
   throw $ mkSrcErr $ unitBag $
     mkPlainErrMsg dflags loc $
         text "Unsupported extension: " <> text unsup $$
-        if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
+        if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
   where
      suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
 
@@ -313,9 +330,9 @@ unsupportedExtnError dflags loc unsup =
 optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
 optionsErrorMsgs dflags 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' ]
-        mkMsg (L flagSpan flag) = 
+  where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
+                                          L l f' <- flags_lines, f == f' ]
+        mkMsg (L flagSpan flag) =
             ErrUtils.mkPlainErrMsg dflags flagSpan $
                     text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag