HeaderInfo.hs 9.86 KB
Newer Older
1 2
-----------------------------------------------------------------------------
--
3
-- | Parsing the top of a Haskell source file to get its module name,
4 5 6 7 8 9 10
-- imports and options.
--
-- (c) Simon Marlow 2005
-- (c) Lemmih 2006
--
-----------------------------------------------------------------------------

11
module HeaderInfo ( getImports
12
                  , getOptionsFromFile, getOptions
13 14
                  , optionsErrorMsgs,
                    checkProcessArgsResult ) where
15 16 17

#include "HsVersions.h"

18
import RdrName
19
import HscTypes
20
import Parser		( parseHeader )
21
import Lexer
22 23
import FastString
import HsSyn		( ImportDecl(..), HsModule(..) )
Simon Marlow's avatar
Simon Marlow committed
24 25
import Module		( ModuleName, moduleName )
import PrelNames        ( gHC_PRIM, mAIN_NAME )
26
import StringBuffer
27
import SrcLoc
28
import DynFlags
29 30 31 32
import ErrUtils
import Util
import Outputable
import Pretty           ()
33
import Maybes
34
import Bag		( emptyBag, listToBag, unitBag )
35

36
import MonadUtils       ( MonadIO )
37
import Exception
38
import Control.Monad
Simon Marlow's avatar
Simon Marlow committed
39
import System.IO
40
import System.IO.Unsafe
Simon Marlow's avatar
Simon Marlow committed
41
import Data.List
42

43 44 45 46 47 48 49 50 51 52 53 54
------------------------------------------------------------------------------

-- | Parse the imports of a source file.
--
-- Throws a 'SourceError' if parsing fails.
getImports :: GhcMonad m =>
              DynFlags
           -> StringBuffer -- ^ Parse this.
           -> FilePath     -- ^ Filename the buffer came from.  Used for
                           --   reporting parse error locations.
           -> FilePath     -- ^ The original source filename (used for locations
                           --   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 59
  let loc  = mkSrcLoc (mkFastString filename) 1 0
  case unP parseHeader (mkPState buf loc dflags) of
60 61
    PFailed span err -> parseError span err
    POk pst rdr_module -> do
Ian Lynagh's avatar
Ian Lynagh committed
62
      let _ms@(_warns, errs) = getMessages pst
63 64
      -- don't log warnings: they'll be reported when we parse the file
      -- for real.  See #2500.
Ian Lynagh's avatar
Ian Lynagh committed
65
          ms = (emptyBag, errs)
66
      -- logWarnings warns
67 68 69
      if errorsFound dflags ms
        then liftIO $ throwIO $ mkSrcErr errs
        else
70
	  case rdr_module of
David Waern's avatar
David Waern committed
71
	    L _ (HsModule mb_mod _ imps _ _ _ _) ->
72
	      let
73 74
                main_loc = mkSrcLoc (mkFastString source_filename) 1 0
		mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
75 76 77
	        (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
		ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) 
					ord_idecls
78 79
		     -- GHC.Prim doesn't exist physically, so don't go looking for it.
	      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 87 88

--------------------------------------------------------------
-- Get options
--------------------------------------------------------------

89 90 91
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
92
getOptionsFromFile :: DynFlags
93 94
                   -> FilePath            -- ^ Input file
                   -> IO [Located String] -- ^ Parsed options, if any.
95
getOptionsFromFile dflags filename
96
    = Exception.bracket
Simon Marlow's avatar
Simon Marlow committed
97
	      (openBinaryFile filename ReadMode)
98
              (hClose)
99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128
              (\handle -> do
                  opts <- fmap getOptions' $ lazyGetToks dflags filename handle
                  seqList opts $ return opts)

blockSize :: Int
-- blockSize = 17 -- for testing :-)
blockSize = 1024

lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
lazyGetToks dflags filename handle = do
  buf <- hGetStringBufferBlock handle blockSize
  unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
 where
  loc  = mkSrcLoc (mkFastString filename) 1 0

  lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
  lazyLexBuf handle state eof = do
    case unP (lexer return) state of
      POk state' t -> do
        -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
        if atEnd (buffer state') && not eof
           -- if this token reached the end of the buffer, and we haven't
           -- necessarily read up to the end of the file, then the token might
           -- be truncated, so read some more of the file and lex it again.
           then getMore handle state
           else case t of
                  L _ ITeof -> return [t]
                  _other    -> do rest <- lazyLexBuf handle state' eof
                                  return (t : rest)
      _ | not eof   -> getMore handle state
129 130 131
        | otherwise -> return [L (last_loc state) ITeof]
                         -- parser assumes an ITeof sentinel at the end

132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
  getMore :: Handle -> PState -> IO [Located Token]
  getMore handle state = do
     -- pprTrace "getMore" (text (show (buffer state))) (return ())
     nextbuf <- hGetStringBufferBlock handle blockSize
     if (len nextbuf == 0) then lazyLexBuf handle state True else do
     newbuf <- appendStringBuffers (buffer state) nextbuf
     unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False


getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
 where
  loc  = mkSrcLoc (mkFastString filename) 1 0

  lexAll state = case unP (lexer return) state of
                   POk _      t@(L _ ITeof) -> [t]
                   POk state' t -> t : lexAll state'
                   _ -> [L (last_loc state) ITeof]

151

152 153 154 155 156 157 158
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
getOptions :: DynFlags
           -> StringBuffer -- ^ Input Buffer
           -> FilePath     -- ^ Source filename.  Used for location info.
           -> [Located String] -- ^ Parsed options.
159
getOptions dflags buf filename
160
    = getOptions' (getToks dflags filename buf)
161 162 163 164 165

-- The token parser is written manually because Happy can't
-- return a partial result when it encounters a lexer error.
-- We want to extract options before the buffer is passed through
-- CPP, so we can't use the same trick as 'getImports'.
166 167 168 169 170 171 172
getOptions' :: [Located Token]      -- Input buffer
            -> [Located String]     -- Options.
getOptions' toks
    = parseToks toks
    where 
          getToken (L _loc tok) = tok
          getLoc (L loc _tok) = loc
173 174 175 176

          parseToks (open:close:xs)
              | IToptions_prag str <- getToken open
              , ITclose_prag       <- getToken close
177
              = map (L (getLoc open)) (words str) ++
178 179 180 181
                parseToks xs
          parseToks (open:close:xs)
              | ITinclude_prag str <- getToken open
              , ITclose_prag       <- getToken close
182
              = map (L (getLoc open)) ["-#include",removeSpaces str] ++
183
                parseToks xs
David Waern's avatar
David Waern committed
184 185 186 187
          parseToks (open:close:xs)
              | ITdocOptions str <- getToken open
              , ITclose_prag     <- getToken close
              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
188
                ++ parseToks xs
David Waern's avatar
David Waern committed
189 190 191
          parseToks (open:xs)
              | ITdocOptionsOld str <- getToken open
              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
192
                ++ parseToks xs
193 194 195
          parseToks (open:xs)
              | ITlanguage_prag <- getToken open
              = parseLanguage xs
196 197 198
          parseToks _ = []
          parseLanguage (L loc (ITconid fs):rest)
              = checkExtension (L loc fs) :
199
                case rest of
200 201 202
                  (L _loc ITcomma):more -> parseLanguage more
                  (L _loc ITclose_prag):more -> parseToks more
                  (L loc _):_ -> languagePragParseError loc
203
                  [] -> panic "getOptions'.parseLanguage(1) went past eof token"
204 205
          parseLanguage (tok:_)
              = languagePragParseError (getLoc tok)
206 207
          parseLanguage []
              = panic "getOptions'.parseLanguage(2) went past eof token"
208

209 210
-----------------------------------------------------------------------------

211 212 213 214
-- | Complain about non-dynamic flags in OPTIONS pragmas.
--
-- Throws a 'SourceError' if the input list is non-empty claiming that the
-- input flags are unknown.
215
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
216 217
checkProcessArgsResult flags
  = when (notNull flags) $
218 219 220 221 222
      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
    where mkMsg (L loc flag)
              = mkPlainErrMsg loc $
                  (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
                   text flag)
223 224 225

-----------------------------------------------------------------------------

226 227
checkExtension :: Located FastString -> Located String
checkExtension (L l ext)
228 229 230 231 232 233 234
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
 =  let ext' = unpackFS ext in
    if ext' `elem` supportedLanguages
       || ext' `elem` (map ("No"++) supportedLanguages)
    then L l ("-X"++ext')
    else unsupportedExtnError l ext'
235

236
languagePragParseError :: SrcSpan -> a
237
languagePragParseError loc =
238 239 240
  throw $ mkSrcErr $ unitBag $
     (mkPlainErrMsg loc $
       text "cannot parse LANGUAGE pragma: comma-separated list expected")
241

242
unsupportedExtnError :: SrcSpan -> String -> a
243
unsupportedExtnError loc unsup =
244 245 246
  throw $ mkSrcErr $ unitBag $
    mkPlainErrMsg loc $
        text "unsupported extension: " <> text unsup
247 248 249


optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
250
optionsErrorMsgs unhandled_flags flags_lines _filename
251 252 253 254 255 256 257
  = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
  where	unhandled_flags_lines = [ L l f | f <- unhandled_flags, 
					  L l f' <- flags_lines, f == f' ]
        mkMsg (L flagSpan flag) = 
            ErrUtils.mkPlainErrMsg flagSpan $
                    text "unknown flag in  {-# OPTIONS #-} pragma:" <+> text flag