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