1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE TypeFamilies #-}
4
5-----------------------------------------------------------------------------
6--
7-- | Parsing the top of a Haskell source file to get its module name,
8-- imports and options.
9--
10-- (c) Simon Marlow 2005
11-- (c) Lemmih 2006
12--
13-----------------------------------------------------------------------------
14
15module HeaderInfo ( getImports
16                  , mkPrelImports -- used by the renamer too
17                  , getOptionsFromFile, getOptions
18                  , optionsErrorMsgs,
19                    checkProcessArgsResult ) where
20
21#include "HsVersions.h"
22
23import GhcPrelude
24
25import GHC.Platform
26import HscTypes
27import Parser           ( parseHeader )
28import Lexer
29import FastString
30import GHC.Hs
31import Module
32import PrelNames
33import StringBuffer
34import SrcLoc
35import DynFlags
36import ErrUtils
37import Util
38import Outputable
39import Maybes
40import Bag              ( emptyBag, listToBag, unitBag )
41import MonadUtils
42import Exception
43import BasicTypes
44import qualified GHC.LanguageExtensions as LangExt
45
46import Control.Monad
47import System.IO
48import System.IO.Unsafe
49import Data.List
50
51------------------------------------------------------------------------------
52
53-- | Parse the imports of a source file.
54--
55-- Throws a 'SourceError' if parsing fails.
56getImports :: DynFlags
57           -> StringBuffer -- ^ Parse this.
58           -> FilePath     -- ^ Filename the buffer came from.  Used for
59                           --   reporting parse error locations.
60           -> FilePath     -- ^ The original source filename (used for locations
61                           --   in the function result)
62           -> IO (Either
63               ErrorMessages
64               ([(Maybe FastString, Located ModuleName)],
65                [(Maybe FastString, Located ModuleName)],
66                Located ModuleName))
67              -- ^ The source imports, normal imports, and the module name.
68getImports dflags buf filename source_filename = do
69  let loc  = mkRealSrcLoc (mkFastString filename) 1 1
70  case unP parseHeader (mkPState dflags buf loc) of
71    PFailed pst ->
72        -- assuming we're not logging warnings here as per below
73      return $ Left $ getErrorMessages pst dflags
74    POk pst rdr_module -> fmap Right $ do
75      let _ms@(_warns, errs) = getMessages pst dflags
76      -- don't log warnings: they'll be reported when we parse the file
77      -- for real.  See #2500.
78          ms = (emptyBag, errs)
79      -- logWarnings warns
80      if errorsFound dflags ms
81        then throwIO $ mkSrcErr errs
82        else
83          let   hsmod = unLoc rdr_module
84                mb_mod = hsmodName hsmod
85                imps = hsmodImports hsmod
86                main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
87                                       1 1)
88                mod = mb_mod `orElse` cL main_loc mAIN_NAME
89                (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
90
91               -- GHC.Prim doesn't exist physically, so don't go looking for it.
92                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc
93                                        . ideclName . unLoc)
94                                       ord_idecls
95
96                implicit_prelude = xopt LangExt.ImplicitPrelude dflags
97                implicit_imports = mkPrelImports (unLoc mod) main_loc
98                                                 implicit_prelude imps
99                convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i)
100                                         , ideclName i)
101              in
102              return (map convImport src_idecls,
103                      map convImport (implicit_imports ++ ordinary_imps),
104                      mod)
105
106mkPrelImports :: ModuleName
107              -> SrcSpan    -- Attribute the "import Prelude" to this location
108              -> Bool -> [LImportDecl GhcPs]
109              -> [LImportDecl GhcPs]
110-- Construct the implicit declaration "import Prelude" (or not)
111--
112-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
113-- because the former doesn't even look at Prelude.hi for instance
114-- declarations, whereas the latter does.
115mkPrelImports this_mod loc implicit_prelude import_decls
116  | this_mod == pRELUDE_NAME
117   || explicit_prelude_import
118   || not implicit_prelude
119  = []
120  | otherwise = [preludeImportDecl]
121  where
122      explicit_prelude_import
123       = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod
124                                        , ideclPkgQual = Nothing }))
125                          <- import_decls
126                      , unLoc mod == pRELUDE_NAME ]
127
128      preludeImportDecl :: LImportDecl GhcPs
129      preludeImportDecl
130        = cL loc $ ImportDecl { ideclExt       = noExtField,
131                                ideclSourceSrc = NoSourceText,
132                                ideclName      = cL loc pRELUDE_NAME,
133                                ideclPkgQual   = Nothing,
134                                ideclSource    = False,
135                                ideclSafe      = False,  -- Not a safe import
136                                ideclQualified = NotQualified,
137                                ideclImplicit  = True,   -- Implicit!
138                                ideclAs        = Nothing,
139                                ideclHiding    = Nothing  }
140
141--------------------------------------------------------------
142-- Get options
143--------------------------------------------------------------
144
145-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
146--
147-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
148getOptionsFromFile :: DynFlags
149                   -> FilePath            -- ^ Input file
150                   -> IO [Located String] -- ^ Parsed options, if any.
151getOptionsFromFile dflags filename
152    = Exception.bracket
153              (openBinaryFile filename ReadMode)
154              (hClose)
155              (\handle -> do
156                  opts <- fmap (getOptions' dflags)
157                               (lazyGetToks dflags' filename handle)
158                  seqList opts $ return opts)
159    where -- We don't need to get haddock doc tokens when we're just
160          -- getting the options from pragmas, and lazily lexing them
161          -- correctly is a little tricky: If there is "\n" or "\n-"
162          -- left at the end of a buffer then the haddock doc may
163          -- continue past the end of the buffer, despite the fact that
164          -- we already have an apparently-complete token.
165          -- We therefore just turn Opt_Haddock off when doing the lazy
166          -- lex.
167          dflags' = gopt_unset dflags Opt_Haddock
168
169blockSize :: Int
170-- blockSize = 17 -- for testing :-)
171blockSize = 1024
172
173lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
174lazyGetToks dflags filename handle = do
175  buf <- hGetStringBufferBlock handle blockSize
176  unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize
177 where
178  loc  = mkRealSrcLoc (mkFastString filename) 1 1
179
180  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
181  lazyLexBuf handle state eof size = do
182    case unP (lexer False return) state of
183      POk state' t -> do
184        -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
185        if atEnd (buffer state') && not eof
186           -- if this token reached the end of the buffer, and we haven't
187           -- necessarily read up to the end of the file, then the token might
188           -- be truncated, so read some more of the file and lex it again.
189           then getMore handle state size
190           else case unLoc t of
191                  ITeof  -> return [t]
192                  _other -> do rest <- lazyLexBuf handle state' eof size
193                               return (t : rest)
194      _ | not eof   -> getMore handle state size
195        | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof]
196                         -- parser assumes an ITeof sentinel at the end
197
198  getMore :: Handle -> PState -> Int -> IO [Located Token]
199  getMore handle state size = do
200     -- pprTrace "getMore" (text (show (buffer state))) (return ())
201     let new_size = size * 2
202       -- double the buffer size each time we read a new block.  This
203       -- counteracts the quadratic slowdown we otherwise get for very
204       -- large module names (#5981)
205     nextbuf <- hGetStringBufferBlock handle new_size
206     if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
207       newbuf <- appendStringBuffers (buffer state) nextbuf
208       unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size
209
210
211getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
212getToks dflags filename buf = lexAll (pragState dflags buf loc)
213 where
214  loc  = mkRealSrcLoc (mkFastString filename) 1 1
215
216  lexAll state = case unP (lexer False return) state of
217                   POk _      t@(dL->L _ ITeof) -> [t]
218                   POk state' t -> t : lexAll state'
219                   _ -> [cL (RealSrcSpan (last_loc state)) ITeof]
220
221
222-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
223--
224-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
225getOptions :: DynFlags
226           -> StringBuffer -- ^ Input Buffer
227           -> FilePath     -- ^ Source filename.  Used for location info.
228           -> [Located String] -- ^ Parsed options.
229getOptions dflags buf filename
230    = getOptions' dflags (getToks dflags filename buf)
231
232-- The token parser is written manually because Happy can't
233-- return a partial result when it encounters a lexer error.
234-- We want to extract options before the buffer is passed through
235-- CPP, so we can't use the same trick as 'getImports'.
236getOptions' :: DynFlags
237            -> [Located Token]      -- Input buffer
238            -> [Located String]     -- Options.
239getOptions' dflags toks
240    = parseToks toks
241    where
242          parseToks (open:close:xs)
243              | IToptions_prag str <- unLoc open
244              , ITclose_prag       <- unLoc close
245              = case toArgs str of
246                  Left _err -> optionsParseError str dflags $   -- #15053
247                                 combineSrcSpans (getLoc open) (getLoc close)
248                  Right args -> map (cL (getLoc open)) args ++ parseToks xs
249          parseToks (open:close:xs)
250              | ITinclude_prag str <- unLoc open
251              , ITclose_prag       <- unLoc close
252              = map (cL (getLoc open)) ["-#include",removeSpaces str] ++
253                parseToks xs
254          parseToks (open:close:xs)
255              | ITdocOptions str <- unLoc open
256              , ITclose_prag     <- unLoc close
257              = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str]
258                ++ parseToks xs
259          parseToks (open:xs)
260              | ITlanguage_prag <- unLoc open
261              = parseLanguage xs
262          parseToks (comment:xs) -- Skip over comments
263              | isComment (unLoc comment)
264              = parseToks xs
265          parseToks _ = []
266          parseLanguage ((dL->L loc (ITconid fs)):rest)
267              = checkExtension dflags (cL loc fs) :
268                case rest of
269                  (dL->L _loc ITcomma):more -> parseLanguage more
270                  (dL->L _loc ITclose_prag):more -> parseToks more
271                  (dL->L loc _):_ -> languagePragParseError dflags loc
272                  [] -> panic "getOptions'.parseLanguage(1) went past eof token"
273          parseLanguage (tok:_)
274              = languagePragParseError dflags (getLoc tok)
275          parseLanguage []
276              = panic "getOptions'.parseLanguage(2) went past eof token"
277
278          isComment :: Token -> Bool
279          isComment c =
280            case c of
281              (ITlineComment {})     -> True
282              (ITblockComment {})    -> True
283              (ITdocCommentNext {})  -> True
284              (ITdocCommentPrev {})  -> True
285              (ITdocCommentNamed {}) -> True
286              (ITdocSection {})      -> True
287              _                      -> False
288
289-----------------------------------------------------------------------------
290
291-- | Complain about non-dynamic flags in OPTIONS pragmas.
292--
293-- Throws a 'SourceError' if the input list is non-empty claiming that the
294-- input flags are unknown.
295checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
296checkProcessArgsResult dflags flags
297  = when (notNull flags) $
298      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
299    where mkMsg (dL->L loc flag)
300              = mkPlainErrMsg dflags loc $
301                  (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
302                   text flag)
303
304-----------------------------------------------------------------------------
305
306checkExtension :: DynFlags -> Located FastString -> Located String
307checkExtension dflags (dL->L l ext)
308-- Checks if a given extension is valid, and if so returns
309-- its corresponding flag. Otherwise it throws an exception.
310  = if ext' `elem` supported
311    then cL l ("-X"++ext')
312    else unsupportedExtnError dflags l ext'
313  where
314    ext' = unpackFS ext
315    supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags
316
317languagePragParseError :: DynFlags -> SrcSpan -> a
318languagePragParseError dflags loc =
319    throwErr dflags loc $
320       vcat [ text "Cannot parse LANGUAGE pragma"
321            , text "Expecting comma-separated list of language options,"
322            , text "each starting with a capital letter"
323            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]
324
325unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
326unsupportedExtnError dflags loc unsup =
327    throwErr dflags loc $
328        text "Unsupported extension: " <> text unsup $$
329        if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
330  where
331     supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags
332     suggestions = fuzzyMatch unsup supported
333
334
335optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
336optionsErrorMsgs dflags unhandled_flags flags_lines _filename
337  = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
338  where unhandled_flags_lines :: [Located String]
339        unhandled_flags_lines = [ cL l f
340                                | f <- unhandled_flags
341                                , (dL->L l f') <- flags_lines
342                                , f == f' ]
343        mkMsg (dL->L flagSpan flag) =
344            ErrUtils.mkPlainErrMsg dflags flagSpan $
345                    text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag
346
347optionsParseError :: String -> DynFlags -> SrcSpan -> a     -- #15053
348optionsParseError str dflags loc =
349  throwErr dflags loc $
350      vcat [ text "Error while parsing OPTIONS_GHC pragma."
351           , text "Expecting whitespace-separated list of GHC options."
352           , text "  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
353           , text ("Input was: " ++ show str) ]
354
355throwErr :: DynFlags -> SrcSpan -> SDoc -> a                -- #15053
356throwErr dflags loc doc =
357  throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc
358