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