HeaderInfo.hs 9.63 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 62 63 64 65 66
    PFailed span err -> parseError span err
    POk pst rdr_module -> do
      let ms@(warns, errs) = getMessages pst
      logWarnings warns
      if errorsFound dflags ms
        then liftIO $ throwIO $ mkSrcErr errs
        else
67
	  case rdr_module of
David Waern's avatar
David Waern committed
68
	    L _ (HsModule mb_mod _ imps _ _ _ _) ->
69
	      let
70 71
                main_loc = mkSrcLoc (mkFastString source_filename) 1 0
		mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
72 73 74
	        (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
		ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) 
					ord_idecls
75 76
		     -- GHC.Prim doesn't exist physically, so don't go looking for it.
	      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 84 85

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

86 87 88
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
89
getOptionsFromFile :: DynFlags
90 91
                   -> FilePath            -- ^ Input file
                   -> IO [Located String] -- ^ Parsed options, if any.
92
getOptionsFromFile dflags filename
93
    = Exception.bracket
Simon Marlow's avatar
Simon Marlow committed
94
	      (openBinaryFile filename ReadMode)
95
              (hClose)
96 97 98 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 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
              (\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
        | otherwise -> return []
  
  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]

147

148 149 150 151 152 153 154
-- | 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.
155
getOptions dflags buf filename
156
    = getOptions' (getToks dflags filename buf)
157 158 159 160 161

-- 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'.
162 163 164 165 166 167 168
getOptions' :: [Located Token]      -- Input buffer
            -> [Located String]     -- Options.
getOptions' toks
    = parseToks toks
    where 
          getToken (L _loc tok) = tok
          getLoc (L loc _tok) = loc
169 170 171 172

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

205 206
-----------------------------------------------------------------------------

207 208 209 210
-- | 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.
211
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
212 213
checkProcessArgsResult flags
  = when (notNull flags) $
214 215 216 217 218
      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
    where mkMsg (L loc flag)
              = mkPlainErrMsg loc $
                  (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
                   text flag)
219 220 221

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

222 223
checkExtension :: Located FastString -> Located String
checkExtension (L l ext)
224 225 226 227 228 229 230
-- 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'
231

232
languagePragParseError :: SrcSpan -> a
233
languagePragParseError loc =
234 235 236
  throw $ mkSrcErr $ unitBag $
     (mkPlainErrMsg loc $
       text "cannot parse LANGUAGE pragma: comma-separated list expected")
237

238
unsupportedExtnError :: SrcSpan -> String -> a
239
unsupportedExtnError loc unsup =
240 241 242
  throw $ mkSrcErr $ unitBag $
    mkPlainErrMsg loc $
        text "unsupported extension: " <> text unsup
243 244 245


optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
246
optionsErrorMsgs unhandled_flags flags_lines _filename
247 248 249 250 251 252 253
  = (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