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 ( getImportsFromFile, getImports
  12                   , getOptionsFromFile, getOptions
  13                   , optionsErrorMsgs ) where
  14
  15 #include "HsVersions.h"
  16
  17 import Parser           ( parseHeader )
  18 import Lexer
  19 import FastString
  20 import HsSyn            ( ImportDecl(..), HsModule(..) )
  21 import Module           ( ModuleName, moduleName )
  22 import PrelNames        ( gHC_PRIM, mAIN_NAME )
  23 import StringBuffer     ( StringBuffer(..), hGetStringBuffer, hGetStringBufferBlock
  24                         , appendStringBuffers )
  25 import SrcLoc
  26 import DynFlags
  27 import ErrUtils
  28 import Util
  29 import Outputable
  30 import Pretty           ()
  31 import Panic
  32 import Maybes
  33 import Bag              ( emptyBag, listToBag )
  34
  35 import Distribution.Compiler
  36
  37 import Control.Exception
  38 import Control.Monad
  39 import System.Exit
  40 import System.IO
  41 import Data.List
  42
  43 #if __GLASGOW_HASKELL__ >= 601
  44 import System.IO                ( openBinaryFile )
  45 #else
  46 import IOExts                   ( openFileEx, IOModeEx(..) )
  47 #endif
  48
  49 #if __GLASGOW_HASKELL__ < 601
  50 openBinaryFile fp mode = openFileEx fp (BinaryMode mode)
  51 #endif
  52
  53 -- getImportsFromFile is careful to close the file afterwards, otherwise
  54 -- we can end up with a large number of open handles before the garbage
  55 -- collector gets around to closing them.
  56 getImportsFromFile :: DynFlags -> FilePath
  57    -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName)
  58 getImportsFromFile dflags filename = do
  59   buf <- hGetStringBuffer filename
  60   getImports dflags buf filename
  61
  62 getImports :: DynFlags -> StringBuffer -> FilePath
  63     -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName)
  64 getImports dflags buf filename = do
  65   let loc  = mkSrcLoc (mkFastString filename) 1 0
  66   case unP parseHeader (mkPState buf loc dflags) of
  67         PFailed span err -> parseError span err
  68         POk pst rdr_module -> do
  69           let ms = getMessages pst
  70           printErrorsAndWarnings dflags ms
  71           when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
  72           case rdr_module of
  73             L _ (HsModule mb_mod _ imps _ _ _ _ _) ->
  74               let
  75                 mod = mb_mod `orElse` L (srcLocSpan loc) mAIN_NAME
  76                 (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps)
  77                 source_imps   = map getImpMod src_idecls
  78                 ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc)
  79                                         (map getImpMod ord_idecls)
  80                      -- GHC.Prim doesn't exist physically, so don't go looking for it.
  81               in
  82               return (source_imps, ordinary_imps, mod)
  83
  84 parseError span err = throwDyn $ mkPlainErrMsg span err
  85
  86 isSourceIdecl (ImportDecl _ s _ _ _) = s
  87
  88 getImpMod (ImportDecl located_mod _ _ _ _) = located_mod
  89
  90 --------------------------------------------------------------
  91 -- Get options
  92 --------------------------------------------------------------
  93
  94
  95 getOptionsFromFile :: FilePath            -- input file
  96                    -> IO [Located String] -- options, if any
  97 getOptionsFromFile filename
  98     = Control.Exception.bracket
  99               (openBinaryFile filename ReadMode)
 100               (hClose)
 101               (\handle ->
 102                    do buf <- hGetStringBufferBlock handle blockSize
 103                       loop handle buf)
 104     where blockSize = 1024
 105           loop handle buf
 106               | len buf == 0 = return []
 107               | otherwise
 108               = case getOptions' buf filename of
 109                   (Nothing, opts) -> return opts
 110                   (Just buf', opts) -> do nextBlock <- hGetStringBufferBlock handle blockSize
 111                                           newBuf <- appendStringBuffers buf' nextBlock
 112                                           if len newBuf == len buf
 113                                              then return opts
 114                                              else do opts' <- loop handle newBuf
 115                                                      return (opts++opts')
 116
 117 getOptions :: StringBuffer -> FilePath -> [Located String]
 118 getOptions buf filename
 119     = case getOptions' buf filename of
 120         (_,opts) -> opts
 121
 122 -- The token parser is written manually because Happy can't
 123 -- return a partial result when it encounters a lexer error.
 124 -- We want to extract options before the buffer is passed through
 125 -- CPP, so we can't use the same trick as 'getImports'.
 126 getOptions' :: StringBuffer         -- Input buffer
 127             -> FilePath             -- Source file. Used for msgs only.
 128             -> ( Maybe StringBuffer -- Just => we can use more input
 129                , [Located String]   -- Options.
 130                )
 131 getOptions' buf filename
 132     = parseToks (lexAll (pragState buf loc))
 133     where loc  = mkSrcLoc (mkFastString filename) 1 0
 134
 135           getToken (buf,L _loc tok) = tok
 136           getLoc (buf,L loc _tok) = loc
 137           getBuf (buf,_tok) = buf
 138           combine opts (flag, opts') = (flag, opts++opts')
 139           add opt (flag, opts) = (flag, opt:opts)
 140
 141           parseToks (open:close:xs)
 142               | IToptions_prag str <- getToken open
 143               , ITclose_prag       <- getToken close
 144               = map (L (getLoc open)) (words str) `combine`
 145                 parseToks xs
 146           parseToks (open:close:xs)
 147               | ITinclude_prag str <- getToken open
 148               , ITclose_prag       <- getToken close
 149               = map (L (getLoc open)) ["-#include",removeSpaces str] `combine`
 150                 parseToks xs
 151           parseToks (open:xs)
 152               | ITlanguage_prag <- getToken open
 153               = parseLanguage xs
 154           -- The last token before EOF could have been truncated.
 155           -- We ignore it to be on the safe side.
 156           parseToks [tok,eof]
 157               | ITeof <- getToken eof
 158               = (Just (getBuf tok),[])
 159           parseToks (eof:_)
 160               | ITeof <- getToken eof
 161               = (Just (getBuf eof),[])
 162           parseToks _ = (Nothing,[])
 163           parseLanguage ((_buf,L loc (ITconid fs)):rest)
 164               = checkExtension (L loc fs) `add`
 165                 case rest of
 166                   (_,L loc ITcomma):more -> parseLanguage more
 167                   (_,L loc ITclose_prag):more -> parseToks more
 168                   (_,L loc _):_ -> languagePragParseError loc
 169           parseLanguage (tok:_)
 170               = languagePragParseError (getLoc tok)
 171           lexToken t = return t
 172           lexAll state = case unP (lexer lexToken) state of
 173                            POk state' t@(L _ ITeof) -> [(buffer state,t)]
 174                            POk state' t -> (buffer state,t):lexAll state'
 175                            _ -> [(buffer state,L (last_loc state) ITeof)]
 176
 177 checkExtension :: Located FastString -> Located String
 178 checkExtension (L l ext)
 179     = case reads (unpackFS ext) of
 180         [] -> languagePragParseError l
 181         (okExt,""):_ -> case extensionsToGHCFlag [okExt] of
 182                           ([],[opt]) -> L l opt
 183                           _ -> unsupportedExtnError l okExt
 184
 185 languagePragParseError loc =
 186   pgmError (showSDoc (mkLocMessage loc (
 187                 text "cannot parse LANGUAGE pragma")))
 188
 189 unsupportedExtnError loc unsup =
 190   pgmError (showSDoc (mkLocMessage loc (
 191                 text "unsupported extension: " <>
 192                 (text.show) unsup)))
 193
 194
 195 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
 196 optionsErrorMsgs unhandled_flags flags_lines filename
 197   = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
 198   where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
 199                                           L l f' <- flags_lines, f == f' ]
 200         mkMsg (L flagSpan flag) =
 201             ErrUtils.mkPlainErrMsg flagSpan $
 202                     text "unknown flag in  {-# OPTIONS #-} pragma:" <+> text flag
 203