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