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 HscTypes
  19 import Parser           ( parseHeader )
  20 import Lexer
  21 import FastString
  22 import HsSyn            ( ImportDecl(..), HsModule(..) )
  23 import Module           ( ModuleName, moduleName )
  24 import PrelNames        ( gHC_PRIM, mAIN_NAME )
  25 import StringBuffer     ( StringBuffer(..), hGetStringBufferBlock
  26                         , appendStringBuffers )
  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 Data.List
  41
  42 ------------------------------------------------------------------------------
  43
  44 -- | Parse the imports of a source file.
  45 --
  46 -- Throws a 'SourceError' if parsing fails.
  47 getImports :: GhcMonad m =>
  48               DynFlags
  49            -> StringBuffer -- ^ Parse this.
  50            -> FilePath     -- ^ Filename the buffer came from.  Used for
  51                            --   reporting parse error locations.
  52            -> FilePath     -- ^ The original source filename (used for locations
  53                            --   in the function result)
  54            -> m ([Located ModuleName], [Located ModuleName], Located ModuleName)
  55               -- ^ The source imports, normal imports, and the module name.
  56 getImports dflags buf filename source_filename = do
  57   let loc  = mkSrcLoc (mkFastString filename) 1 0
  58   case unP parseHeader (mkPState buf loc dflags) of
  59     PFailed span err -> parseError span err
  60     POk pst rdr_module -> do
  61       let ms@(warns, errs) = getMessages pst
  62       logWarnings warns
  63       if errorsFound dflags ms
  64         then liftIO $ throwIO $ mkSrcErr errs
  65         else
  66           case rdr_module of
  67             L _ (HsModule mb_mod _ imps _ _ _ _) ->
  68               let
  69                 main_loc = mkSrcLoc (mkFastString source_filename) 1 0
  70                 mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
  71                 imps' = filter isHomeImp (map unLoc imps)
  72                 (src_idecls, ord_idecls) = partition isSourceIdecl imps'
  73                 source_imps   = map getImpMod src_idecls
  74                 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc)
  75                                         (map getImpMod ord_idecls)
  76                      -- GHC.Prim doesn't exist physically, so don't go looking for it.
  77               in
  78               return (source_imps, ordinary_imps, mod)
  79
  80 parseError :: GhcMonad m => SrcSpan -> Message -> m a
  81 parseError span err = throwOneError $ mkPlainErrMsg span err
  82
  83 -- we aren't interested in package imports here, filter them out
  84 isHomeImp :: ImportDecl name -> Bool
  85 isHomeImp (ImportDecl _ (Just p) _ _ _ _) = p == fsLit "this"
  86 isHomeImp (ImportDecl _ Nothing  _ _ _ _) = True
  87
  88 isSourceIdecl :: ImportDecl name -> Bool
  89 isSourceIdecl (ImportDecl _ _ s _ _ _) = s
  90
  91 getImpMod :: ImportDecl name -> Located ModuleName
  92 getImpMod (ImportDecl located_mod _ _ _ _ _) = located_mod
  93
  94 --------------------------------------------------------------
  95 -- Get options
  96 --------------------------------------------------------------
  97
  98
  99 getOptionsFromFile :: DynFlags
 100                    -> FilePath            -- input file
 101                    -> IO [Located String] -- options, if any
 102 getOptionsFromFile dflags filename
 103     = Exception.bracket
 104               (openBinaryFile filename ReadMode)
 105               (hClose)
 106               (\handle ->
 107                    do buf <- hGetStringBufferBlock handle blockSize
 108                       loop handle buf)
 109     where blockSize = 1024
 110           loop handle buf
 111               | len buf == 0 = return []
 112               | otherwise
 113               = case getOptions' dflags buf filename of
 114                   (Nothing, opts) -> return opts
 115                   (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
 116                                           newBuf <- appendStringBuffers buf' nextBlock
 117                                           if len newBuf == len buf
 118                                              then return opts
 119                                              else do opts' <- loop handle newBuf
 120                                                      return (opts++opts')
 121
 122 getOptions :: DynFlags -> StringBuffer -> FilePath -> [Located String]
 123 getOptions dflags buf filename
 124     = case getOptions' dflags buf filename of
 125         (_,opts) -> opts
 126
 127 -- The token parser is written manually because Happy can't
 128 -- return a partial result when it encounters a lexer error.
 129 -- We want to extract options before the buffer is passed through
 130 -- CPP, so we can't use the same trick as 'getImports'.
 131 getOptions' :: DynFlags
 132             -> StringBuffer         -- Input buffer
 133             -> FilePath             -- Source file. Used for msgs only.
 134             -> ( Maybe StringBuffer -- Just => we can use more input
 135                , [Located String]   -- Options.
 136                )
 137 getOptions' dflags buf filename
 138     = parseToks (lexAll (pragState dflags buf loc))
 139     where loc  = mkSrcLoc (mkFastString filename) 1 0
 140
 141           getToken (_buf,L _loc tok) = tok
 142           getLoc (_buf,L loc _tok) = loc
 143           getBuf (buf,_tok) = buf
 144           combine opts (flag, opts') = (flag, opts++opts')
 145           add opt (flag, opts) = (flag, opt:opts)
 146
 147           parseToks (open:close:xs)
 148               | IToptions_prag str <- getToken open
 149               , ITclose_prag       <- getToken close
 150               = map (L (getLoc open)) (words str) `combine`
 151                 parseToks xs
 152           parseToks (open:close:xs)
 153               | ITinclude_prag str <- getToken open
 154               , ITclose_prag       <- getToken close
 155               = map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
 156                 parseToks xs
 157           parseToks (open:close:xs)
 158               | ITdocOptions str <- getToken open
 159               , ITclose_prag     <- getToken close
 160               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
 161                 `combine` parseToks xs
 162           parseToks (open:xs)
 163               | ITdocOptionsOld str <- getToken open
 164               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
 165                 `combine` parseToks xs
 166           parseToks (open:xs)
 167               | ITlanguage_prag <- getToken open
 168               = parseLanguage xs
 169           -- The last token before EOF could have been truncated.
 170           -- We ignore it to be on the safe side.
 171           parseToks [tok,eof]
 172               | ITeof <- getToken eof
 173               = (Just (getBuf tok),[])
 174           parseToks (eof:_)
 175               | ITeof <- getToken eof
 176               = (Just (getBuf eof),[])
 177           parseToks _ = (Nothing,[])
 178           parseLanguage ((_buf,L loc (ITconid fs)):rest)
 179               = checkExtension (L loc fs) `add`
 180                 case rest of
 181                   (_,L _loc ITcomma):more -> parseLanguage more
 182                   (_,L _loc ITclose_prag):more -> parseToks more
 183                   (_,L loc _):_ -> languagePragParseError loc
 184                   [] -> panic "getOptions'.parseLanguage(1) went past eof token"
 185           parseLanguage (tok:_)
 186               = languagePragParseError (getLoc tok)
 187           parseLanguage []
 188               = panic "getOptions'.parseLanguage(2) went past eof token"
 189           lexToken t = return t
 190           lexAll state = case unP (lexer lexToken) state of
 191                            POk _      t@(L _ ITeof) -> [(buffer state,t)]
 192                            POk state' t -> (buffer state,t):lexAll state'
 193                            _ -> [(buffer state,L (last_loc state) ITeof)]
 194
 195 -----------------------------------------------------------------------------
 196 -- Complain about non-dynamic flags in OPTIONS pragmas
 197
 198 checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
 199 checkProcessArgsResult flags
 200   = when (notNull flags) $
 201       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
 202     where mkMsg (L loc flag)
 203               = mkPlainErrMsg loc $
 204                   (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
 205                    text flag)
 206
 207 -----------------------------------------------------------------------------
 208
 209 checkExtension :: Located FastString -> Located String
 210 checkExtension (L l ext)
 211 -- Checks if a given extension is valid, and if so returns
 212 -- its corresponding flag. Otherwise it throws an exception.
 213  =  let ext' = unpackFS ext in
 214     if ext' `elem` supportedLanguages
 215        || ext' `elem` (map ("No"++) supportedLanguages)
 216     then L l ("-X"++ext')
 217     else unsupportedExtnError l ext'
 218
 219 languagePragParseError :: SrcSpan -> a
 220 languagePragParseError loc =
 221   throw $ mkSrcErr $ unitBag $
 222      (mkPlainErrMsg loc $
 223        text "cannot parse LANGUAGE pragma: comma-separated list expected")
 224
 225 unsupportedExtnError :: SrcSpan -> String -> a
 226 unsupportedExtnError loc unsup =
 227   throw $ mkSrcErr $ unitBag $
 228     mkPlainErrMsg loc $
 229         text "unsupported extension: " <> text unsup
 230
 231
 232 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
 233 optionsErrorMsgs unhandled_flags flags_lines _filename
 234   = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
 235   where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
 236                                           L l f' <- flags_lines, f == f' ]
 237         mkMsg (L flagSpan flag) =
 238             ErrUtils.mkPlainErrMsg flagSpan $
 239                     text "unknown flag in  {-# OPTIONS #-} pragma:" <+> text flag
 240