Add some commented-out tracing in SpecConstr
[ghc.git] / compiler / main / HeaderInfo.hs
index 6ea12e5..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 span err
+    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,23 +113,24 @@ 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  }
-
-parseError :: SrcSpan -> MsgDoc -> IO a
-parseError span err = throwOneError $ mkPlainErrMsg span err
+        = 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
 
 --------------------------------------------------------------
 -- Get options
@@ -138,10 +144,11 @@ 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' $ lazyGetToks dflags' filename handle
+                  opts <- fmap (getOptions' dflags)
+                               (lazyGetToks dflags' filename handle)
                   seqList opts $ return opts)
     where -- We don't need to get haddock doc tokens when we're just
           -- getting the options from pragmas, and lazily lexing them
@@ -151,7 +158,7 @@ getOptionsFromFile dflags filename
           -- we already have an apparently-complete token.
           -- We therefore just turn Opt_Haddock off when doing the lazy
           -- lex.
-          dflags' = dopt_unset dflags Opt_Haddock
+          dflags' = gopt_unset dflags Opt_Haddock
 
 blockSize :: Int
 -- blockSize = 17 -- for testing :-)
@@ -166,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
@@ -191,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]
@@ -200,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]
@@ -214,25 +221,27 @@ getOptions :: DynFlags
            -> FilePath     -- ^ Source filename.  Used for location info.
            -> [Located String] -- ^ Parsed options.
 getOptions dflags buf filename
-    = getOptions' (getToks dflags filename buf)
+    = getOptions' dflags (getToks dflags filename buf)
 
 -- 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' :: [Located Token]      -- Input buffer
+getOptions' :: DynFlags
+            -> [Located Token]      -- Input buffer
             -> [Located String]     -- Options.
-getOptions' toks
+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
@@ -244,76 +253,86 @@ getOptions' 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 (L loc fs) :
+              = checkExtension dflags (L loc fs) :
                 case rest of
                   (L _loc ITcomma):more -> parseLanguage more
                   (L _loc ITclose_prag):more -> parseToks more
-                  (L loc _):_ -> languagePragParseError loc
+                  (L loc _):_ -> languagePragParseError dflags loc
                   [] -> panic "getOptions'.parseLanguage(1) went past eof token"
           parseLanguage (tok:_)
-              = languagePragParseError (getLoc tok)
+              = languagePragParseError dflags (getLoc tok)
           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.
 --
 -- Throws a 'SourceError' if the input list is non-empty claiming that the
 -- input flags are unknown.
-checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
-checkProcessArgsResult flags
+checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
+checkProcessArgsResult dflags flags
   = when (notNull flags) $
       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
     where mkMsg (L loc flag)
-              = mkPlainErrMsg loc $
+              = mkPlainErrMsg dflags loc $
                   (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
                    text flag)
 
 -----------------------------------------------------------------------------
 
-checkExtension :: Located FastString -> Located String
-checkExtension (L l ext)
+checkExtension :: DynFlags -> Located FastString -> Located String
+checkExtension dflags (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` supportedLanguagesAndExtensions
     then L l ("-X"++ext')
-    else unsupportedExtnError l ext'
+    else unsupportedExtnError dflags l ext'
 
-languagePragParseError :: SrcSpan -> a
-languagePragParseError loc =
+languagePragParseError :: DynFlags -> SrcSpan -> a
+languagePragParseError dflags loc =
   throw $ mkSrcErr $ unitBag $
-     (mkPlainErrMsg loc $
+     (mkPlainErrMsg 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 :: SrcSpan -> String -> a
-unsupportedExtnError loc unsup =
+unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
+unsupportedExtnError dflags loc unsup =
   throw $ mkSrcErr $ unitBag $
-    mkPlainErrMsg loc $
+    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
 
 
-optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
-optionsErrorMsgs unhandled_flags flags_lines _filename
+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) = 
-            ErrUtils.mkPlainErrMsg flagSpan $
+  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