compiler/main/HeaderInfo.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- | Parsing the top of a Haskell source file to get its module name,
   4 -- imports and options.
   5 --
   6 -- (c) Simon Marlow 2005
   7 -- (c) Lemmih 2006
   8 --
   9 -----------------------------------------------------------------------------
  10
  11 module HeaderInfo ( getImports
  12                   , mkPrelImports -- used by the renamer too
  13                   , getOptionsFromFile, getOptions
  14                   , optionsErrorMsgs,
  15                     checkProcessArgsResult ) where
  16
  17 #include "HsVersions.h"
  18
  19 import RdrName
  20 import HscTypes
  21 import Parser           ( parseHeader )
  22 import Lexer
  23 import FastString
  24 import HsSyn
  25 import Module
  26 import PrelNames
  27 import StringBuffer
  28 import SrcLoc
  29 import DynFlags
  30 import ErrUtils
  31 import Util
  32 import Outputable
  33 import Pretty           ()
  34 import Maybes
  35 import Bag              ( emptyBag, listToBag, unitBag )
  36 import MonadUtils
  37 import Exception
  38
  39 import Control.Monad
  40 import System.IO
  41 import System.IO.Unsafe
  42 import Data.List
  43
  44 ------------------------------------------------------------------------------
  45
  46 -- | Parse the imports of a source file.
  47 --
  48 -- Throws a 'SourceError' if parsing fails.
  49 getImports :: DynFlags
  50            -> StringBuffer -- ^ Parse this.
  51            -> FilePath     -- ^ Filename the buffer came from.  Used for
  52                            --   reporting parse error locations.
  53            -> FilePath     -- ^ The original source filename (used for locations
  54                            --   in the function result)
  55            -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
  56               -- ^ The source imports, normal imports, and the module name.
  57 getImports dflags buf filename source_filename = do
  58   let loc  = mkSrcLoc (mkFastString filename) 1 1
  59   case unP parseHeader (mkPState dflags buf loc) of
  60     PFailed span err -> parseError span err
  61     POk pst rdr_module -> do
  62       let _ms@(_warns, errs) = getMessages pst
  63       -- don't log warnings: they'll be reported when we parse the file
  64       -- for real.  See #2500.
  65           ms = (emptyBag, errs)
  66       -- logWarnings warns
  67       if errorsFound dflags ms
  68         then throwIO $ mkSrcErr errs
  69         else
  70           case rdr_module of
  71             L _ (HsModule mb_mod _ imps _ _ _) ->
  72               let
  73                 main_loc = mkSrcLoc (mkFastString source_filename) 1 1
  74                 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
  75                 (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
  76
  77                      -- GHC.Prim doesn't exist physically, so don't go looking for it.
  78                 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
  79                                         ord_idecls
  80
  81                 implicit_prelude = xopt Opt_ImplicitPrelude dflags
  82                 implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps
  83               in
  84               return (src_idecls, implicit_imports ++ ordinary_imps, mod)
  85
  86 mkPrelImports :: ModuleName -> Bool -> [LImportDecl RdrName]
  87               -> [LImportDecl RdrName]
  88 -- Consruct the implicit declaration "import Prelude" (or not)
  89 --
  90 -- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
  91 -- because the former doesn't even look at Prelude.hi for instance
  92 -- declarations, whereas the latter does.
  93 mkPrelImports this_mod implicit_prelude import_decls
  94   | this_mod == pRELUDE_NAME
  95    || explicit_prelude_import
  96    || not implicit_prelude
  97   = []
  98   | otherwise = [preludeImportDecl]
  99   where
 100       explicit_prelude_import
 101        = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _) <- import_decls,
 102                    unLoc mod == pRELUDE_NAME ]
 103
 104       preludeImportDecl :: LImportDecl RdrName
 105       preludeImportDecl
 106         = L loc $
 107           ImportDecl (L loc pRELUDE_NAME)
 108                Nothing {- no specific package -}
 109                False {- Not a boot interface -}
 110                False    {- Not qualified -}
 111                Nothing  {- No "as" -}
 112                Nothing  {- No import list -}
 113
 114       loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")
 115
 116 parseError :: SrcSpan -> Message -> IO a
 117 parseError span err = throwOneError $ mkPlainErrMsg span err
 118
 119 --------------------------------------------------------------
 120 -- Get options
 121 --------------------------------------------------------------
 122
 123 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
 124 --
 125 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
 126 getOptionsFromFile :: DynFlags
 127                    -> FilePath            -- ^ Input file
 128                    -> IO [Located String] -- ^ Parsed options, if any.
 129 getOptionsFromFile dflags filename
 130     = Exception.bracket
 131               (openBinaryFile filename ReadMode)
 132               (hClose)
 133               (\handle -> do
 134                   opts <- fmap getOptions' $ lazyGetToks dflags filename handle
 135                   seqList opts $ return opts)
 136
 137 blockSize :: Int
 138 -- blockSize = 17 -- for testing :-)
 139 blockSize = 1024
 140
 141 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
 142 lazyGetToks dflags filename handle = do
 143   buf <- hGetStringBufferBlock handle blockSize
 144   unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
 145  where
 146   loc  = mkSrcLoc (mkFastString filename) 1 1
 147
 148   lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
 149   lazyLexBuf handle state eof = do
 150     case unP (lexer return) state of
 151       POk state' t -> do
 152         -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
 153         if atEnd (buffer state') && not eof
 154            -- if this token reached the end of the buffer, and we haven't
 155            -- necessarily read up to the end of the file, then the token might
 156            -- be truncated, so read some more of the file and lex it again.
 157            then getMore handle state
 158            else case t of
 159                   L _ ITeof -> return [t]
 160                   _other    -> do rest <- lazyLexBuf handle state' eof
 161                                   return (t : rest)
 162       _ | not eof   -> getMore handle state
 163         | otherwise -> return [L (last_loc state) ITeof]
 164                          -- parser assumes an ITeof sentinel at the end
 165
 166   getMore :: Handle -> PState -> IO [Located Token]
 167   getMore handle state = do
 168      -- pprTrace "getMore" (text (show (buffer state))) (return ())
 169      nextbuf <- hGetStringBufferBlock handle blockSize
 170      if (len nextbuf == 0) then lazyLexBuf handle state True else do
 171      newbuf <- appendStringBuffers (buffer state) nextbuf
 172      unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False
 173
 174
 175 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
 176 getToks dflags filename buf = lexAll (pragState dflags buf loc)
 177  where
 178   loc  = mkSrcLoc (mkFastString filename) 1 1
 179
 180   lexAll state = case unP (lexer return) state of
 181                    POk _      t@(L _ ITeof) -> [t]
 182                    POk state' t -> t : lexAll state'
 183                    _ -> [L (last_loc state) ITeof]
 184
 185
 186 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
 187 --
 188 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
 189 getOptions :: DynFlags
 190            -> StringBuffer -- ^ Input Buffer
 191            -> FilePath     -- ^ Source filename.  Used for location info.
 192            -> [Located String] -- ^ Parsed options.
 193 getOptions dflags buf filename
 194     = getOptions' (getToks dflags filename buf)
 195
 196 -- The token parser is written manually because Happy can't
 197 -- return a partial result when it encounters a lexer error.
 198 -- We want to extract options before the buffer is passed through
 199 -- CPP, so we can't use the same trick as 'getImports'.
 200 getOptions' :: [Located Token]      -- Input buffer
 201             -> [Located String]     -- Options.
 202 getOptions' toks
 203     = parseToks toks
 204     where
 205           getToken (L _loc tok) = tok
 206           getLoc (L loc _tok) = loc
 207
 208           parseToks (open:close:xs)
 209               | IToptions_prag str <- getToken open
 210               , ITclose_prag       <- getToken close
 211               = map (L (getLoc open)) (words str) ++
 212                 parseToks xs
 213           parseToks (open:close:xs)
 214               | ITinclude_prag str <- getToken open
 215               , ITclose_prag       <- getToken close
 216               = map (L (getLoc open)) ["-#include",removeSpaces str] ++
 217                 parseToks xs
 218           parseToks (open:close:xs)
 219               | ITdocOptions str <- getToken open
 220               , ITclose_prag     <- getToken close
 221               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
 222                 ++ parseToks xs
 223           parseToks (open:xs)
 224               | ITdocOptionsOld str <- getToken open
 225               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
 226                 ++ parseToks xs
 227           parseToks (open:xs)
 228               | ITlanguage_prag <- getToken open
 229               = parseLanguage xs
 230           parseToks (x:xs)
 231               | ITdocCommentNext _ <- getToken x
 232               = parseToks xs
 233           parseToks _ = []
 234           parseLanguage (L loc (ITconid fs):rest)
 235               = checkExtension (L loc fs) :
 236                 case rest of
 237                   (L _loc ITcomma):more -> parseLanguage more
 238                   (L _loc ITclose_prag):more -> parseToks more
 239                   (L loc _):_ -> languagePragParseError loc
 240                   [] -> panic "getOptions'.parseLanguage(1) went past eof token"
 241           parseLanguage (tok:_)
 242               = languagePragParseError (getLoc tok)
 243           parseLanguage []
 244               = panic "getOptions'.parseLanguage(2) went past eof token"
 245
 246 -----------------------------------------------------------------------------
 247
 248 -- | Complain about non-dynamic flags in OPTIONS pragmas.
 249 --
 250 -- Throws a 'SourceError' if the input list is non-empty claiming that the
 251 -- input flags are unknown.
 252 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
 253 checkProcessArgsResult flags
 254   = when (notNull flags) $
 255       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
 256     where mkMsg (L loc flag)
 257               = mkPlainErrMsg loc $
 258                   (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
 259                    text flag)
 260
 261 -----------------------------------------------------------------------------
 262
 263 checkExtension :: Located FastString -> Located String
 264 checkExtension (L l ext)
 265 -- Checks if a given extension is valid, and if so returns
 266 -- its corresponding flag. Otherwise it throws an exception.
 267  =  let ext' = unpackFS ext in
 268     if ext' `elem` supportedLanguagesAndExtensions
 269     then L l ("-X"++ext')
 270     else unsupportedExtnError l ext'
 271
 272 languagePragParseError :: SrcSpan -> a
 273 languagePragParseError loc =
 274   throw $ mkSrcErr $ unitBag $
 275      (mkPlainErrMsg loc $
 276        vcat [ text "Cannot parse LANGUAGE pragma"
 277             , text "Expecting comma-separated list of language options,"
 278             , text "each starting with a capital letter"
 279             , nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ])
 280
 281 unsupportedExtnError :: SrcSpan -> String -> a
 282 unsupportedExtnError loc unsup =
 283   throw $ mkSrcErr $ unitBag $
 284     mkPlainErrMsg loc $
 285         text "Unsupported extension: " <> text unsup $$
 286         if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
 287   where
 288      suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
 289
 290
 291 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
 292 optionsErrorMsgs unhandled_flags flags_lines _filename
 293   = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
 294   where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
 295                                           L l f' <- flags_lines, f == f' ]
 296         mkMsg (L flagSpan flag) =
 297             ErrUtils.mkPlainErrMsg flagSpan $
 298                     text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag
 299