HeaderInfo.hs 13.9 KB
Newer Older
1
2
{-# LANGUAGE CPP #-}

3
4
-----------------------------------------------------------------------------
--
5
-- | Parsing the top of a Haskell source file to get its module name,
6
7
8
9
10
11
12
-- imports and options.
--
-- (c) Simon Marlow 2005
-- (c) Lemmih 2006
--
-----------------------------------------------------------------------------

13
module HeaderInfo ( getImports
14
                  , mkPrelImports -- used by the renamer too
15
                  , getOptionsFromFile, getOptions
16
17
                  , optionsErrorMsgs,
                    checkProcessArgsResult ) where
18
19
20

#include "HsVersions.h"

21
import RdrName
22
import HscTypes
23
import Parser           ( parseHeader )
24
import Lexer
25
import FastString
26
27
28
import HsSyn
import Module
import PrelNames
29
import StringBuffer
30
import SrcLoc
31
import DynFlags
32
33
34
35
import ErrUtils
import Util
import Outputable
import Pretty           ()
36
import Maybes
37
import Bag              ( emptyBag, listToBag, unitBag )
38
import MonadUtils
39
import Exception
40
import BasicTypes
41

42
import Control.Monad
Simon Marlow's avatar
Simon Marlow committed
43
import System.IO
44
import System.IO.Unsafe
Simon Marlow's avatar
Simon Marlow committed
45
import Data.List
46

47
48
49
50
51
------------------------------------------------------------------------------

-- | Parse the imports of a source file.
--
-- Throws a 'SourceError' if parsing fails.
52
getImports :: DynFlags
53
54
55
56
57
           -> 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)
58
59
60
           -> IO ([(Maybe FastString, Located ModuleName)],
                  [(Maybe FastString, Located ModuleName)],
                  Located ModuleName)
61
              -- ^ The source imports, normal imports, and the module name.
62
getImports dflags buf filename source_filename = do
Ian Lynagh's avatar
Ian Lynagh committed
63
  let loc  = mkRealSrcLoc (mkFastString filename) 1 1
64
  case unP parseHeader (mkPState dflags buf loc) of
Ian Lynagh's avatar
Ian Lynagh committed
65
    PFailed span err -> parseError dflags span err
66
    POk pst rdr_module -> do
Ian Lynagh's avatar
Ian Lynagh committed
67
      let _ms@(_warns, errs) = getMessages pst
68
69
      -- don't log warnings: they'll be reported when we parse the file
      -- for real.  See #2500.
Ian Lynagh's avatar
Ian Lynagh committed
70
          ms = (emptyBag, errs)
71
      -- logWarnings warns
72
      if errorsFound dflags ms
73
        then throwIO $ mkSrcErr errs
74
        else
75
76
77
          case rdr_module of
            L _ (HsModule mb_mod _ imps _ _ _) ->
              let
78
                main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1)
79
80
                mod = mb_mod `orElse` L main_loc mAIN_NAME
                (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
81

82
83
84
                     -- GHC.Prim doesn't exist physically, so don't go looking for it.
                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
                                       ord_idecls
85

86
                implicit_prelude = xopt Opt_ImplicitPrelude dflags
87
88
                implicit_imports = mkPrelImports (unLoc mod) main_loc
                                                 implicit_prelude imps
89
                convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
90
              in
91
92
93
              return (map convImport src_idecls,
                      map convImport (implicit_imports ++ ordinary_imps),
                      mod)
94

95
mkPrelImports :: ModuleName
96
97
              -> SrcSpan    -- Attribute the "import Prelude" to this location
              -> Bool -> [LImportDecl RdrName]
98
99
100
101
102
103
              -> [LImportDecl RdrName]
-- Consruct the implicit declaration "import Prelude" (or not)
--
-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
-- because the former doesn't even look at Prelude.hi for instance
-- declarations, whereas the latter does.
104
mkPrelImports this_mod loc implicit_prelude import_decls
105
106
107
108
109
110
111
  | this_mod == pRELUDE_NAME
   || explicit_prelude_import
   || not implicit_prelude
  = []
  | otherwise = [preludeImportDecl]
  where
      explicit_prelude_import
112
       = notNull [ () | L _ (ImportDecl { ideclName = mod
113
                                        , ideclPkgQual = Nothing })
114
                          <- import_decls
115
                      , unLoc mod == pRELUDE_NAME ]
116
117
118

      preludeImportDecl :: LImportDecl RdrName
      preludeImportDecl
Alan Zimmerman's avatar
Alan Zimmerman committed
119
120
        = L loc $ ImportDecl { ideclSourceSrc = Nothing,
                               ideclName      = L loc pRELUDE_NAME,
121
122
123
124
125
126
127
                               ideclPkgQual   = Nothing,
                               ideclSource    = False,
                               ideclSafe      = False,  -- Not a safe import
                               ideclQualified = False,
                               ideclImplicit  = True,   -- Implicit!
                               ideclAs        = Nothing,
                               ideclHiding    = Nothing  }
128

Ian Lynagh's avatar
Ian Lynagh committed
129
130
parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a
parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err
131
132
133
134
135

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

136
137
138
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
139
getOptionsFromFile :: DynFlags
140
141
                   -> FilePath            -- ^ Input file
                   -> IO [Located String] -- ^ Parsed options, if any.
142
getOptionsFromFile dflags filename
143
    = Exception.bracket
144
              (openBinaryFile filename ReadMode)
145
              (hClose)
146
              (\handle -> do
Ian Lynagh's avatar
Ian Lynagh committed
147
148
                  opts <- fmap (getOptions' dflags)
                               (lazyGetToks dflags' filename handle)
149
                  seqList opts $ return opts)
150
151
152
153
154
155
156
157
    where -- We don't need to get haddock doc tokens when we're just
          -- getting the options from pragmas, and lazily lexing them
          -- correctly is a little tricky: If there is "\n" or "\n-"
          -- left at the end of a buffer then the haddock doc may
          -- continue past the end of the buffer, despite the fact that
          -- we already have an apparently-complete token.
          -- We therefore just turn Opt_Haddock off when doing the lazy
          -- lex.
ian@well-typed.com's avatar
ian@well-typed.com committed
158
          dflags' = gopt_unset dflags Opt_Haddock
159
160
161
162
163
164
165
166

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

lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
lazyGetToks dflags filename handle = do
  buf <- hGetStringBufferBlock handle blockSize
167
  unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize
168
 where
Ian Lynagh's avatar
Ian Lynagh committed
169
  loc  = mkRealSrcLoc (mkFastString filename) 1 1
170

171
172
  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
  lazyLexBuf handle state eof size = do
Alan Zimmerman's avatar
Alan Zimmerman committed
173
    case unP (lexer False return) state of
174
175
176
177
178
179
      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.
180
           then getMore handle state size
181
182
           else case t of
                  L _ ITeof -> return [t]
183
                  _other    -> do rest <- lazyLexBuf handle state' eof size
184
                                  return (t : rest)
185
      _ | not eof   -> getMore handle state size
Ian Lynagh's avatar
Ian Lynagh committed
186
        | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
187
188
                         -- parser assumes an ITeof sentinel at the end

189
190
  getMore :: Handle -> PState -> Int -> IO [Located Token]
  getMore handle state size = do
191
     -- pprTrace "getMore" (text (show (buffer state))) (return ())
192
193
194
195
196
197
     let new_size = size * 2
       -- double the buffer size each time we read a new block.  This
       -- counteracts the quadratic slowdown we otherwise get for very
       -- large module names (#5981)
     nextbuf <- hGetStringBufferBlock handle new_size
     if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
198
199
       newbuf <- appendStringBuffers (buffer state) nextbuf
       unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size
200
201
202
203
204


getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
 where
Ian Lynagh's avatar
Ian Lynagh committed
205
  loc  = mkRealSrcLoc (mkFastString filename) 1 1
206

Alan Zimmerman's avatar
Alan Zimmerman committed
207
  lexAll state = case unP (lexer False return) state of
208
209
                   POk _      t@(L _ ITeof) -> [t]
                   POk state' t -> t : lexAll state'
Ian Lynagh's avatar
Ian Lynagh committed
210
                   _ -> [L (RealSrcSpan (last_loc state)) ITeof]
211

212

213
214
215
216
217
218
219
-- | 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.
220
getOptions dflags buf filename
Ian Lynagh's avatar
Ian Lynagh committed
221
    = getOptions' dflags (getToks dflags filename buf)
222
223
224
225
226

-- 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'.
Ian Lynagh's avatar
Ian Lynagh committed
227
228
getOptions' :: DynFlags
            -> [Located Token]      -- Input buffer
229
            -> [Located String]     -- Options.
Ian Lynagh's avatar
Ian Lynagh committed
230
getOptions' dflags toks
231
    = parseToks toks
232
    where
233
234
          getToken (L _loc tok) = tok
          getLoc (L loc _tok) = loc
235
236
237
238

          parseToks (open:close:xs)
              | IToptions_prag str <- getToken open
              , ITclose_prag       <- getToken close
239
240
241
              = case toArgs str of
                  Left err -> panic ("getOptions'.parseToks: " ++ err)
                  Right args -> map (L (getLoc open)) args ++ parseToks xs
242
243
244
          parseToks (open:close:xs)
              | ITinclude_prag str <- getToken open
              , ITclose_prag       <- getToken close
245
              = map (L (getLoc open)) ["-#include",removeSpaces str] ++
246
                parseToks xs
David Waern's avatar
David Waern committed
247
248
249
250
          parseToks (open:close:xs)
              | ITdocOptions str <- getToken open
              , ITclose_prag     <- getToken close
              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
251
                ++ parseToks xs
David Waern's avatar
David Waern committed
252
253
254
          parseToks (open:xs)
              | ITdocOptionsOld str <- getToken open
              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
255
                ++ parseToks xs
256
257
258
          parseToks (open:xs)
              | ITlanguage_prag <- getToken open
              = parseLanguage xs
259
260
261
          parseToks (comment:xs) -- Skip over comments
              | isComment (getToken comment)
              = parseToks xs
262
263
          parseToks _ = []
          parseLanguage (L loc (ITconid fs):rest)
Ian Lynagh's avatar
Ian Lynagh committed
264
              = checkExtension dflags (L loc fs) :
265
                case rest of
266
267
                  (L _loc ITcomma):more -> parseLanguage more
                  (L _loc ITclose_prag):more -> parseToks more
Ian Lynagh's avatar
Ian Lynagh committed
268
                  (L loc _):_ -> languagePragParseError dflags loc
269
                  [] -> panic "getOptions'.parseLanguage(1) went past eof token"
270
          parseLanguage (tok:_)
Ian Lynagh's avatar
Ian Lynagh committed
271
              = languagePragParseError dflags (getLoc tok)
272
273
          parseLanguage []
              = panic "getOptions'.parseLanguage(2) went past eof token"
274

275
276
277
278
279
280
281
282
283
284
285
          isComment :: Token -> Bool
          isComment c =
            case c of
              (ITlineComment {})     -> True
              (ITblockComment {})    -> True
              (ITdocCommentNext {})  -> True
              (ITdocCommentPrev {})  -> True
              (ITdocCommentNamed {}) -> True
              (ITdocSection {})      -> True
              _                      -> False

286
287
-----------------------------------------------------------------------------

288
289
290
291
-- | 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.
Ian Lynagh's avatar
Ian Lynagh committed
292
293
checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
checkProcessArgsResult dflags flags
294
  = when (notNull flags) $
295
296
      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
    where mkMsg (L loc flag)
Ian Lynagh's avatar
Ian Lynagh committed
297
              = mkPlainErrMsg dflags loc $
298
                  (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
299
                   text flag)
300
301
302

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

Ian Lynagh's avatar
Ian Lynagh committed
303
304
checkExtension :: DynFlags -> Located FastString -> Located String
checkExtension dflags (L l ext)
305
306
307
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
 =  let ext' = unpackFS ext in
308
    if ext' `elem` supportedLanguagesAndExtensions
309
    then L l ("-X"++ext')
Ian Lynagh's avatar
Ian Lynagh committed
310
    else unsupportedExtnError dflags l ext'
311

Ian Lynagh's avatar
Ian Lynagh committed
312
313
languagePragParseError :: DynFlags -> SrcSpan -> a
languagePragParseError dflags loc =
314
  throw $ mkSrcErr $ unitBag $
Ian Lynagh's avatar
Ian Lynagh committed
315
     (mkPlainErrMsg dflags loc $
316
317
318
       vcat [ text "Cannot parse LANGUAGE pragma"
            , text "Expecting comma-separated list of language options,"
            , text "each starting with a capital letter"
319
            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ])
320

Ian Lynagh's avatar
Ian Lynagh committed
321
322
unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
unsupportedExtnError dflags loc unsup =
323
  throw $ mkSrcErr $ unitBag $
Ian Lynagh's avatar
Ian Lynagh committed
324
    mkPlainErrMsg dflags loc $
325
        text "Unsupported extension: " <> text unsup $$
326
        if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
327
328
  where
     suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
329
330


Ian Lynagh's avatar
Ian Lynagh committed
331
332
optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
optionsErrorMsgs dflags unhandled_flags flags_lines _filename
333
  = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
334
335
336
  where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
                                          L l f' <- flags_lines, f == f' ]
        mkMsg (L flagSpan flag) =
Ian Lynagh's avatar
Ian Lynagh committed
337
            ErrUtils.mkPlainErrMsg dflags flagSpan $
338
                    text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag
339