HeaderInfo.hs 11.5 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
                  , mkPrelImports -- used by the renamer too
13
                  , getOptionsFromFile, getOptions
14 15
                  , optionsErrorMsgs,
                    checkProcessArgsResult ) where
16 17 18

#include "HsVersions.h"

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

39
import Control.Monad
Simon Marlow's avatar
Simon Marlow committed
40
import System.IO
41
import System.IO.Unsafe
Simon Marlow's avatar
Simon Marlow committed
42
import Data.List
43

44 45 46 47 48
------------------------------------------------------------------------------

-- | Parse the imports of a source file.
--
-- Throws a 'SourceError' if parsing fails.
49
getImports :: DynFlags
50 51 52 53 54
           -> 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
           -> IO ([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
Ian Lynagh's avatar
Ian Lynagh committed
58
  let loc  = mkRealSrcLoc (mkFastString filename) 1 1
59
  case unP parseHeader (mkPState dflags buf loc) 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
      if errorsFound dflags ms
68
        then throwIO $ mkSrcErr errs
69
        else
70
	  case rdr_module of
71
	    L _ (HsModule mb_mod _ imps _ _ _) ->
72
	      let
73
                main_loc = mkSrcLoc (mkFastString source_filename) 1 1
74
		mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
75
	        (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
76 77

		     -- GHC.Prim doesn't exist physically, so don't go looking for it.
78 79
		ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) 
					ord_idecls
80

81
                implicit_prelude = xopt Opt_ImplicitPrelude dflags
82
                implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps
83
	      in
84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100
	      return (src_idecls, implicit_imports ++ ordinary_imps, mod)

mkPrelImports :: ModuleName -> Bool -> [LImportDecl RdrName]
              -> [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.
mkPrelImports this_mod implicit_prelude import_decls
  | this_mod == pRELUDE_NAME
   || explicit_prelude_import
   || not implicit_prelude
  = []
  | otherwise = [preludeImportDecl]
  where
      explicit_prelude_import
101
       = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _ _) <- import_decls,
102 103 104 105 106
	           unLoc mod == pRELUDE_NAME ]

      preludeImportDecl :: LImportDecl RdrName
      preludeImportDecl
        = L loc $
107 108 109 110 111 112 113
          ImportDecl (L loc pRELUDE_NAME)
               Nothing  {- No specific package -}
               False    {- Not a boot interface -}
               False    {- Not a safe import -}
               False    {- Not qualified -}
               Nothing  {- No "as" -}
               Nothing  {- No import list -}
114 115 116

      loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")

117
parseError :: SrcSpan -> Message -> IO a
118
parseError span err = throwOneError $ mkPlainErrMsg span err
119 120 121 122 123

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

124 125 126
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
127
getOptionsFromFile :: DynFlags
128 129
                   -> FilePath            -- ^ Input file
                   -> IO [Located String] -- ^ Parsed options, if any.
130
getOptionsFromFile dflags filename
131
    = Exception.bracket
Simon Marlow's avatar
Simon Marlow committed
132
	      (openBinaryFile filename ReadMode)
133
              (hClose)
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
Ian Lynagh's avatar
Ian Lynagh committed
147
  loc  = mkRealSrcLoc (mkFastString filename) 1 1
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163

  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
Ian Lynagh's avatar
Ian Lynagh committed
164
        | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
165 166
                         -- parser assumes an ITeof sentinel at the end

167 168 169 170 171 172 173 174 175 176 177 178
  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
Ian Lynagh's avatar
Ian Lynagh committed
179
  loc  = mkRealSrcLoc (mkFastString filename) 1 1
180 181 182 183

  lexAll state = case unP (lexer return) state of
                   POk _      t@(L _ ITeof) -> [t]
                   POk state' t -> t : lexAll state'
Ian Lynagh's avatar
Ian Lynagh committed
184
                   _ -> [L (RealSrcSpan (last_loc state)) ITeof]
185

186

187 188 189 190 191 192 193
-- | 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.
194
getOptions dflags buf filename
195
    = getOptions' (getToks dflags filename buf)
196 197 198 199 200

-- 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'.
201 202 203 204 205 206 207
getOptions' :: [Located Token]      -- Input buffer
            -> [Located String]     -- Options.
getOptions' toks
    = parseToks toks
    where 
          getToken (L _loc tok) = tok
          getLoc (L loc _tok) = loc
208 209 210 211

          parseToks (open:close:xs)
              | IToptions_prag str <- getToken open
              , ITclose_prag       <- getToken close
212
              = map (L (getLoc open)) (words str) ++
213 214 215 216
                parseToks xs
          parseToks (open:close:xs)
              | ITinclude_prag str <- getToken open
              , ITclose_prag       <- getToken close
217
              = map (L (getLoc open)) ["-#include",removeSpaces str] ++
218
                parseToks xs
David Waern's avatar
David Waern committed
219 220 221 222
          parseToks (open:close:xs)
              | ITdocOptions str <- getToken open
              , ITclose_prag     <- getToken close
              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
223
                ++ parseToks xs
David Waern's avatar
David Waern committed
224 225 226
          parseToks (open:xs)
              | ITdocOptionsOld str <- getToken open
              = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
227
                ++ parseToks xs
228 229 230
          parseToks (open:xs)
              | ITlanguage_prag <- getToken open
              = parseLanguage xs
231 232 233
          parseToks (x:xs)
              | ITdocCommentNext _ <- getToken x
              = parseToks xs
234 235 236
          parseToks _ = []
          parseLanguage (L loc (ITconid fs):rest)
              = checkExtension (L loc fs) :
237
                case rest of
238 239 240
                  (L _loc ITcomma):more -> parseLanguage more
                  (L _loc ITclose_prag):more -> parseToks more
                  (L loc _):_ -> languagePragParseError loc
241
                  [] -> panic "getOptions'.parseLanguage(1) went past eof token"
242 243
          parseLanguage (tok:_)
              = languagePragParseError (getLoc tok)
244 245
          parseLanguage []
              = panic "getOptions'.parseLanguage(2) went past eof token"
246

247 248
-----------------------------------------------------------------------------

249 250 251 252
-- | 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.
253
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
254 255
checkProcessArgsResult flags
  = when (notNull flags) $
256 257 258
      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
    where mkMsg (L loc flag)
              = mkPlainErrMsg loc $
259
                  (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
260
                   text flag)
261 262 263

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

264 265
checkExtension :: Located FastString -> Located String
checkExtension (L l ext)
266 267 268
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
 =  let ext' = unpackFS ext in
269
    if ext' `elem` supportedLanguagesAndExtensions
270 271
    then L l ("-X"++ext')
    else unsupportedExtnError l ext'
272

273
languagePragParseError :: SrcSpan -> a
274
languagePragParseError loc =
275 276
  throw $ mkSrcErr $ unitBag $
     (mkPlainErrMsg loc $
277 278 279 280
       vcat [ text "Cannot parse LANGUAGE pragma"
            , text "Expecting comma-separated list of language options,"
            , text "each starting with a capital letter"
            , nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ])
281

282
unsupportedExtnError :: SrcSpan -> String -> a
283
unsupportedExtnError loc unsup =
284 285
  throw $ mkSrcErr $ unitBag $
    mkPlainErrMsg loc $
286 287
        text "Unsupported extension: " <> text unsup $$
        if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
288 289
  where
     suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
290 291 292


optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
293
optionsErrorMsgs unhandled_flags flags_lines _filename
294 295 296 297 298
  = (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 $
299
                    text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag
300