HeaderInfo.hs 9.73 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
              (\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
126
127
128
        | otherwise -> return [L (last_loc state) ITeof]
                         -- parser assumes an ITeof sentinel at the end

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
  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]

148

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

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

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

206
207
-----------------------------------------------------------------------------

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

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

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

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

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


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