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                   , getOptionsFromFile, getOptions
  13                   , optionsErrorMsgs,
  14                     checkProcessArgsResult ) where
  15
  16 #include "HsVersions.h"
  17
  18 import RdrName
  19 import HscTypes
  20 import Parser           ( parseHeader )
  21 import Lexer
  22 import FastString
  23 import HsSyn            ( ImportDecl(..), HsModule(..) )
  24 import Module           ( ModuleName, moduleName )
  25 import PrelNames        ( gHC_PRIM, mAIN_NAME )
  26 import StringBuffer
  27 import SrcLoc
  28 import DynFlags
  29 import ErrUtils
  30 import Util
  31 import Outputable
  32 import Pretty           ()
  33 import Maybes
  34 import Bag              ( emptyBag, listToBag, unitBag )
  35
  36 import MonadUtils       ( MonadIO )
  37 import Exception
  38 import Control.Monad
  39 import System.IO
  40 import System.IO.Unsafe
  41 import Data.List
  42
  43 ------------------------------------------------------------------------------
  44
  45 -- | Parse the imports of a source file.
  46 --
  47 -- Throws a 'SourceError' if parsing fails.
  48 getImports :: GhcMonad m =>
  49               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            -> m ([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 0
  59   case unP parseHeader (mkPState buf loc dflags) 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       -- logWarnings warns
  66       if errorsFound dflags ms
  67         then liftIO $ throwIO $ mkSrcErr errs
  68         else
  69           case rdr_module of
  70             L _ (HsModule mb_mod _ imps _ _ _ _) ->
  71               let
  72                 main_loc = mkSrcLoc (mkFastString source_filename) 1 0
  73                 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
  74                 (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
  75                 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
  76                                         ord_idecls
  77                      -- GHC.Prim doesn't exist physically, so don't go looking for it.
  78               in
  79               return (src_idecls, ordinary_imps, mod)
  80
  81 parseError :: GhcMonad m => SrcSpan -> Message -> m a
  82 parseError span err = throwOneError $ mkPlainErrMsg span err
  83
  84 --------------------------------------------------------------
  85 -- Get options
  86 --------------------------------------------------------------
  87
  88 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
  89 --
  90 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
  91 getOptionsFromFile :: DynFlags
  92                    -> FilePath            -- ^ Input file
  93                    -> IO [Located String] -- ^ Parsed options, if any.
  94 getOptionsFromFile dflags filename
  95     = Exception.bracket
  96               (openBinaryFile filename ReadMode)
  97               (hClose)
  98               (\handle -> do
  99                   opts <- fmap getOptions' $ lazyGetToks dflags filename handle
 100                   seqList opts $ return opts)
 101
 102 blockSize :: Int
 103 -- blockSize = 17 -- for testing :-)
 104 blockSize = 1024
 105
 106 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
 107 lazyGetToks dflags filename handle = do
 108   buf <- hGetStringBufferBlock handle blockSize
 109   unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
 110  where
 111   loc  = mkSrcLoc (mkFastString filename) 1 0
 112
 113   lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
 114   lazyLexBuf handle state eof = do
 115     case unP (lexer return) state of
 116       POk state' t -> do
 117         -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
 118         if atEnd (buffer state') && not eof
 119            -- if this token reached the end of the buffer, and we haven't
 120            -- necessarily read up to the end of the file, then the token might
 121            -- be truncated, so read some more of the file and lex it again.
 122            then getMore handle state
 123            else case t of
 124                   L _ ITeof -> return [t]
 125                   _other    -> do rest <- lazyLexBuf handle state' eof
 126                                   return (t : rest)
 127       _ | not eof   -> getMore handle state
 128         | otherwise -> return [L (last_loc state) ITeof]
 129                          -- parser assumes an ITeof sentinel at the end
 130
 131   getMore :: Handle -> PState -> IO [Located Token]
 132   getMore handle state = do
 133      -- pprTrace "getMore" (text (show (buffer state))) (return ())
 134      nextbuf <- hGetStringBufferBlock handle blockSize
 135      if (len nextbuf == 0) then lazyLexBuf handle state True else do
 136      newbuf <- appendStringBuffers (buffer state) nextbuf
 137      unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False
 138
 139
 140 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
 141 getToks dflags filename buf = lexAll (pragState dflags buf loc)
 142  where
 143   loc  = mkSrcLoc (mkFastString filename) 1 0
 144
 145   lexAll state = case unP (lexer return) state of
 146                    POk _      t@(L _ ITeof) -> [t]
 147                    POk state' t -> t : lexAll state'
 148                    _ -> [L (last_loc state) ITeof]
 149
 150
 151 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
 152 --
 153 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
 154 getOptions :: DynFlags
 155            -> StringBuffer -- ^ Input Buffer
 156            -> FilePath     -- ^ Source filename.  Used for location info.
 157            -> [Located String] -- ^ Parsed options.
 158 getOptions dflags buf filename
 159     = getOptions' (getToks dflags filename buf)
 160
 161 -- The token parser is written manually because Happy can't
 162 -- return a partial result when it encounters a lexer error.
 163 -- We want to extract options before the buffer is passed through
 164 -- CPP, so we can't use the same trick as 'getImports'.
 165 getOptions' :: [Located Token]      -- Input buffer
 166             -> [Located String]     -- Options.
 167 getOptions' toks
 168     = parseToks toks
 169     where
 170           getToken (L _loc tok) = tok
 171           getLoc (L loc _tok) = loc
 172
 173           parseToks (open:close:xs)
 174               | IToptions_prag str <- getToken open
 175               , ITclose_prag       <- getToken close
 176               = map (L (getLoc open)) (words str) ++
 177                 parseToks xs
 178           parseToks (open:close:xs)
 179               | ITinclude_prag str <- getToken open
 180               , ITclose_prag       <- getToken close
 181               = map (L (getLoc open)) ["-#include",removeSpaces str] ++
 182                 parseToks xs
 183           parseToks (open:close:xs)
 184               | ITdocOptions str <- getToken open
 185               , ITclose_prag     <- getToken close
 186               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
 187                 ++ parseToks xs
 188           parseToks (open:xs)
 189               | ITdocOptionsOld str <- getToken open
 190               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
 191                 ++ parseToks xs
 192           parseToks (open:xs)
 193               | ITlanguage_prag <- getToken open
 194               = parseLanguage xs
 195           parseToks _ = []
 196           parseLanguage (L loc (ITconid fs):rest)
 197               = checkExtension (L loc fs) :
 198                 case rest of
 199                   (L _loc ITcomma):more -> parseLanguage more
 200                   (L _loc ITclose_prag):more -> parseToks more
 201                   (L loc _):_ -> languagePragParseError loc
 202                   [] -> panic "getOptions'.parseLanguage(1) went past eof token"
 203           parseLanguage (tok:_)
 204               = languagePragParseError (getLoc tok)
 205           parseLanguage []
 206               = panic "getOptions'.parseLanguage(2) went past eof token"
 207
 208 -----------------------------------------------------------------------------
 209
 210 -- | Complain about non-dynamic flags in OPTIONS pragmas.
 211 --
 212 -- Throws a 'SourceError' if the input list is non-empty claiming that the
 213 -- input flags are unknown.
 214 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
 215 checkProcessArgsResult flags
 216   = when (notNull flags) $
 217       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
 218     where mkMsg (L loc flag)
 219               = mkPlainErrMsg loc $
 220                   (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
 221                    text flag)
 222
 223 -----------------------------------------------------------------------------
 224
 225 checkExtension :: Located FastString -> Located String
 226 checkExtension (L l ext)
 227 -- Checks if a given extension is valid, and if so returns
 228 -- its corresponding flag. Otherwise it throws an exception.
 229  =  let ext' = unpackFS ext in
 230     if ext' `elem` supportedLanguages
 231        || ext' `elem` (map ("No"++) supportedLanguages)
 232     then L l ("-X"++ext')
 233     else unsupportedExtnError l ext'
 234
 235 languagePragParseError :: SrcSpan -> a
 236 languagePragParseError loc =
 237   throw $ mkSrcErr $ unitBag $
 238      (mkPlainErrMsg loc $
 239        text "cannot parse LANGUAGE pragma: comma-separated list expected")
 240
 241 unsupportedExtnError :: SrcSpan -> String -> a
 242 unsupportedExtnError loc unsup =
 243   throw $ mkSrcErr $ unitBag $
 244     mkPlainErrMsg loc $
 245         text "unsupported extension: " <> text unsup
 246
 247
 248 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
 249 optionsErrorMsgs unhandled_flags flags_lines _filename
 250   = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
 251   where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
 252                                           L l f' <- flags_lines, f == f' ]
 253         mkMsg (L flagSpan flag) =
 254             ErrUtils.mkPlainErrMsg flagSpan $
 255                     text "unknown flag in  {-# OPTIONS #-} pragma:" <+> text flag
 256