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