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     ( StringBuffer(..), hGetStringBufferBlock
  27                         , appendStringBuffers )
  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 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 ->
  97                    do buf <- hGetStringBufferBlock handle blockSize
  98                       loop handle buf)
  99     where blockSize = 1024
 100           loop handle buf
 101               | len buf == 0 = return []
 102               | otherwise
 103               = case getOptions' dflags buf filename of
 104                   (Nothing, opts) -> return opts
 105                   (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
 106                                           newBuf <- appendStringBuffers buf' nextBlock
 107                                           if len newBuf == len buf
 108                                              then return opts
 109                                              else do opts' <- loop handle newBuf
 110                                                      return (opts++opts')
 111
 112 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
 113 --
 114 -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
 115 getOptions :: DynFlags
 116            -> StringBuffer -- ^ Input Buffer
 117            -> FilePath     -- ^ Source filename.  Used for location info.
 118            -> [Located String] -- ^ Parsed options.
 119 getOptions dflags buf filename
 120     = case getOptions' dflags buf filename of
 121         (_,opts) -> opts
 122
 123 -- The token parser is written manually because Happy can't
 124 -- return a partial result when it encounters a lexer error.
 125 -- We want to extract options before the buffer is passed through
 126 -- CPP, so we can't use the same trick as 'getImports'.
 127 getOptions' :: DynFlags
 128             -> StringBuffer         -- Input buffer
 129             -> FilePath             -- Source file. Used for msgs only.
 130             -> ( Maybe StringBuffer -- Just => we can use more input
 131                , [Located String]   -- Options.
 132                )
 133 getOptions' dflags buf filename
 134     = parseToks (lexAll (pragState dflags buf loc))
 135     where loc  = mkSrcLoc (mkFastString filename) 1 0
 136
 137           getToken (_buf,L _loc tok) = tok
 138           getLoc (_buf,L loc _tok) = loc
 139           getBuf (buf,_tok) = buf
 140           combine opts (flag, opts') = (flag, opts++opts')
 141           add opt (flag, opts) = (flag, opt:opts)
 142
 143           parseToks (open:close:xs)
 144               | IToptions_prag str <- getToken open
 145               , ITclose_prag       <- getToken close
 146               = map (L (getLoc open)) (words str) `combine`
 147                 parseToks xs
 148           parseToks (open:close:xs)
 149               | ITinclude_prag str <- getToken open
 150               , ITclose_prag       <- getToken close
 151               = map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
 152                 parseToks xs
 153           parseToks (open:close:xs)
 154               | ITdocOptions str <- getToken open
 155               , ITclose_prag     <- getToken close
 156               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
 157                 `combine` parseToks xs
 158           parseToks (open:xs)
 159               | ITdocOptionsOld str <- getToken open
 160               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
 161                 `combine` parseToks xs
 162           parseToks (open:xs)
 163               | ITlanguage_prag <- getToken open
 164               = parseLanguage xs
 165           -- The last token before EOF could have been truncated.
 166           -- We ignore it to be on the safe side.
 167           parseToks [tok,eof]
 168               | ITeof <- getToken eof
 169               = (Just (getBuf tok),[])
 170           parseToks (eof:_)
 171               | ITeof <- getToken eof
 172               = (Just (getBuf eof),[])
 173           parseToks _ = (Nothing,[])
 174           parseLanguage ((_buf,L loc (ITconid fs)):rest)
 175               = checkExtension (L loc fs) `add`
 176                 case rest of
 177                   (_,L _loc ITcomma):more -> parseLanguage more
 178                   (_,L _loc ITclose_prag):more -> parseToks more
 179                   (_,L loc _):_ -> languagePragParseError loc
 180                   [] -> panic "getOptions'.parseLanguage(1) went past eof token"
 181           parseLanguage (tok:_)
 182               = languagePragParseError (getLoc tok)
 183           parseLanguage []
 184               = panic "getOptions'.parseLanguage(2) went past eof token"
 185           lexToken t = return t
 186           lexAll state = case unP (lexer lexToken) state of
 187                            POk _      t@(L _ ITeof) -> [(buffer state,t)]
 188                            POk state' t -> (buffer state,t):lexAll state'
 189                            _ -> [(buffer state,L (last_loc state) ITeof)]
 190
 191 -----------------------------------------------------------------------------
 192
 193 -- | Complain about non-dynamic flags in OPTIONS pragmas.
 194 --
 195 -- Throws a 'SourceError' if the input list is non-empty claiming that the
 196 -- input flags are unknown.
 197 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
 198 checkProcessArgsResult flags
 199   = when (notNull flags) $
 200       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
 201     where mkMsg (L loc flag)
 202               = mkPlainErrMsg loc $
 203                   (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
 204                    text flag)
 205
 206 -----------------------------------------------------------------------------
 207
 208 checkExtension :: Located FastString -> Located String
 209 checkExtension (L l ext)
 210 -- Checks if a given extension is valid, and if so returns
 211 -- its corresponding flag. Otherwise it throws an exception.
 212  =  let ext' = unpackFS ext in
 213     if ext' `elem` supportedLanguages
 214        || ext' `elem` (map ("No"++) supportedLanguages)
 215     then L l ("-X"++ext')
 216     else unsupportedExtnError l ext'
 217
 218 languagePragParseError :: SrcSpan -> a
 219 languagePragParseError loc =
 220   throw $ mkSrcErr $ unitBag $
 221      (mkPlainErrMsg loc $
 222        text "cannot parse LANGUAGE pragma: comma-separated list expected")
 223
 224 unsupportedExtnError :: SrcSpan -> String -> a
 225 unsupportedExtnError loc unsup =
 226   throw $ mkSrcErr $ unitBag $
 227     mkPlainErrMsg loc $
 228         text "unsupported extension: " <> text unsup
 229
 230
 231 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
 232 optionsErrorMsgs unhandled_flags flags_lines _filename
 233   = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
 234   where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
 235                                           L l f' <- flags_lines, f == f' ]
 236         mkMsg (L flagSpan flag) =
 237             ErrUtils.mkPlainErrMsg flagSpan $
 238                     text "unknown flag in  {-# OPTIONS #-} pragma:" <+> text flag
 239