{-# LANGUAGE CPP          #-}
{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------
--
-- | Parsing the top of a Haskell source file to get its module name,
-- imports and options.
--
-- (c) Simon Marlow 2005
-- (c) Lemmih 2006
--
-----------------------------------------------------------------------------

module GHC.Parser.Header
   ( getImports
   , mkPrelImports -- used by the renamer too
   , getOptionsFromFile
   , getOptions
   , optionsErrorMsgs
   , checkProcessArgsResult
   )
where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Platform

import GHC.Driver.Session
import GHC.Driver.Config

import GHC.Parser.Errors.Ppr
import GHC.Parser.Errors
import GHC.Parser           ( parseHeader )
import GHC.Parser.Lexer

import GHC.Hs
import GHC.Unit.Module
import GHC.Builtin.Names

import GHC.Types.Error hiding ( getErrorMessages, getWarningMessages )
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.SourceText

import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Monad
import GHC.Utils.Exception as Exception

import GHC.Data.StringBuffer
import GHC.Data.Maybe
import GHC.Data.Bag         ( Bag, listToBag, unitBag, isEmptyBag )
import GHC.Data.FastString

import Control.Monad
import System.IO
import System.IO.Unsafe
import Data.List (partition)

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

-- | Parse the imports of a source file.
--
-- Throws a 'SourceError' if parsing fails.
getImports :: ParserOpts   -- ^ Parser options
           -> Bool         -- ^ Implicit Prelude?
           -> 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)
           -> IO (Either
               (Bag PsError)
               ([(Maybe FastString, Located ModuleName)],
                [(Maybe FastString, Located ModuleName)],
                Located ModuleName))
              -- ^ The source imports and normal imports (with optional package
              -- names from -XPackageImports), and the module name.
getImports :: ParserOpts
-> Bool
-> StringBuffer
-> String
-> String
-> IO
     (Either
        (Bag PsError)
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
getImports ParserOpts
popts Bool
implicit_prelude StringBuffer
buf String
filename String
source_filename = do
  let loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1
  case P (Located HsModule) -> PState -> ParseResult (Located HsModule)
forall a. P a -> PState -> ParseResult a
unP P (Located HsModule)
parseHeader (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc) of
    PFailed PState
pst ->
        -- assuming we're not logging warnings here as per below
      Either
  (Bag PsError)
  ([(Maybe FastString, Located ModuleName)],
   [(Maybe FastString, Located ModuleName)], Located ModuleName)
-> IO
     (Either
        (Bag PsError)
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (Bag PsError)
   ([(Maybe FastString, Located ModuleName)],
    [(Maybe FastString, Located ModuleName)], Located ModuleName)
 -> IO
      (Either
         (Bag PsError)
         ([(Maybe FastString, Located ModuleName)],
          [(Maybe FastString, Located ModuleName)], Located ModuleName)))
-> Either
     (Bag PsError)
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
-> IO
     (Either
        (Bag PsError)
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
forall a b. (a -> b) -> a -> b
$ Bag PsError
-> Either
     (Bag PsError)
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
forall a b. a -> Either a b
Left (Bag PsError
 -> Either
      (Bag PsError)
      ([(Maybe FastString, Located ModuleName)],
       [(Maybe FastString, Located ModuleName)], Located ModuleName))
-> Bag PsError
-> Either
     (Bag PsError)
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
forall a b. (a -> b) -> a -> b
$ PState -> Bag PsError
getErrorMessages PState
pst
    POk PState
pst Located HsModule
rdr_module -> (([(Maybe FastString, Located ModuleName)],
  [(Maybe FastString, Located ModuleName)], Located ModuleName)
 -> Either
      (Bag PsError)
      ([(Maybe FastString, Located ModuleName)],
       [(Maybe FastString, Located ModuleName)], Located ModuleName))
-> IO
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
-> IO
     (Either
        (Bag PsError)
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Maybe FastString, Located ModuleName)],
 [(Maybe FastString, Located ModuleName)], Located ModuleName)
-> Either
     (Bag PsError)
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
forall a b. b -> Either a b
Right (IO
   ([(Maybe FastString, Located ModuleName)],
    [(Maybe FastString, Located ModuleName)], Located ModuleName)
 -> IO
      (Either
         (Bag PsError)
         ([(Maybe FastString, Located ModuleName)],
          [(Maybe FastString, Located ModuleName)], Located ModuleName)))
-> IO
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
-> IO
     (Either
        (Bag PsError)
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
forall a b. (a -> b) -> a -> b
$ do
      let (Bag PsWarning
_warns, Bag PsError
errs) = PState -> (Bag PsWarning, Bag PsError)
getMessages PState
pst
      -- don't log warnings: they'll be reported when we parse the file
      -- for real.  See #2500.
      if Bool -> Bool
not (Bag PsError -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag PsError
errs)
        then SourceError
-> IO
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
forall e a. Exception e => e -> IO a
throwIO (SourceError
 -> IO
      ([(Maybe FastString, Located ModuleName)],
       [(Maybe FastString, Located ModuleName)], Located ModuleName))
-> SourceError
-> IO
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> SourceError
mkSrcErr ((PsError -> MsgEnvelope DecoratedSDoc)
-> Bag PsError -> ErrorMessages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError Bag PsError
errs)
        else
          let   hsmod :: HsModule
hsmod = Located HsModule -> HsModule
forall l e. GenLocated l e -> e
unLoc Located HsModule
rdr_module
                mb_mod :: Maybe (GenLocated SrcSpanAnnA ModuleName)
mb_mod = HsModule -> Maybe (GenLocated SrcSpanAnnA ModuleName)
hsmodName HsModule
hsmod
                imps :: [LImportDecl GhcPs]
imps = HsModule -> [LImportDecl GhcPs]
hsmodImports HsModule
hsmod
                main_loc :: SrcSpan
main_loc = SrcLoc -> SrcSpan
srcLocSpan (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (String -> FastString
mkFastString String
source_filename)
                                       Int
1 Int
1)
                mod :: GenLocated SrcSpanAnnA ModuleName
mod = Maybe (GenLocated SrcSpanAnnA ModuleName)
mb_mod Maybe (GenLocated SrcSpanAnnA ModuleName)
-> GenLocated SrcSpanAnnA ModuleName
-> GenLocated SrcSpanAnnA ModuleName
forall a. Maybe a -> a -> a
`orElse` SrcSpanAnnA -> ModuleName -> GenLocated SrcSpanAnnA ModuleName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
main_loc) ModuleName
mAIN_NAME
                ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls) = (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
    [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (IsBootInterface -> Bool)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> IsBootInterface)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> IsBootInterface
forall pass. ImportDecl pass -> IsBootInterface
ideclSource (ImportDecl GhcPs -> IsBootInterface)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> IsBootInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc) [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
[LImportDecl GhcPs]
imps

               -- GHC.Prim doesn't exist physically, so don't go looking for it.
                ordinary_imps :: [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps = (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
gHC_PRIM) (ModuleName -> Bool)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ModuleName)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc
                                        (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs)
    -> GenLocated SrcSpanAnnA ModuleName)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName (ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> GenLocated SrcSpanAnnA ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc)
                                       [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls

                implicit_imports :: [LImportDecl GhcPs]
implicit_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA ModuleName
mod) SrcSpan
main_loc
                                                 Bool
implicit_prelude [LImportDecl GhcPs]
imps
                convImport :: GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport (L l
_ ImportDecl pass
i) = ((StringLiteral -> FastString)
-> Maybe StringLiteral -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs (ImportDecl pass -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl pass
i), GenLocated (SrcAnn a) ModuleName -> Located ModuleName
forall a e. LocatedAn a e -> Located e
reLoc (ImportDecl pass -> XRec pass ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
i))
              in
              ([(Maybe FastString, Located ModuleName)],
 [(Maybe FastString, Located ModuleName)], Located ModuleName)
-> IO
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
forall (m :: * -> *) a. Monad m => a -> m a
return ((GenLocated SrcSpanAnnA (ImportDecl GhcPs)
 -> (Maybe FastString, Located ModuleName))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (Maybe FastString, Located ModuleName)
forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls,
                      (GenLocated SrcSpanAnnA (ImportDecl GhcPs)
 -> (Maybe FastString, Located ModuleName))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (Maybe FastString, Located ModuleName)
forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
[LImportDecl GhcPs]
implicit_imports [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps),
                      GenLocated SrcSpanAnnA ModuleName -> Located ModuleName
forall a e. LocatedAn a e -> Located e
reLoc GenLocated SrcSpanAnnA ModuleName
mod)

mkPrelImports :: ModuleName
              -> SrcSpan    -- Attribute the "import Prelude" to this location
              -> Bool -> [LImportDecl GhcPs]
              -> [LImportDecl GhcPs]
-- Construct 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 :: ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports ModuleName
this_mod SrcSpan
loc Bool
implicit_prelude [LImportDecl GhcPs]
import_decls
  | ModuleName
this_mod ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME
   Bool -> Bool -> Bool
|| Bool
explicit_prelude_import
   Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
implicit_prelude
  = []
  | Bool
otherwise = [LImportDecl GhcPs
preludeImportDecl]
  where
      explicit_prelude_import :: Bool
explicit_prelude_import = (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool
forall {pass} {l} {l}.
(XRec pass ModuleName ~ GenLocated l ModuleName) =>
GenLocated l (ImportDecl pass) -> Bool
is_prelude_import [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
[LImportDecl GhcPs]
import_decls

      is_prelude_import :: GenLocated l (ImportDecl pass) -> Bool
is_prelude_import (L l
_ ImportDecl pass
decl) =
        GenLocated l ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl pass -> XRec pass ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
decl) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME
        -- allow explicit "base" package qualifier (#19082, #17045)
        Bool -> Bool -> Bool
&& case ImportDecl pass -> Maybe StringLiteral
forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl pass
decl of
            Maybe StringLiteral
Nothing -> Bool
True
            Just StringLiteral
b  -> StringLiteral -> FastString
sl_fs StringLiteral
b FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId -> FastString
unitIdFS UnitId
baseUnitId


      loc' :: SrcSpanAnnA
loc' = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
      preludeImportDecl :: LImportDecl GhcPs
      preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
        = SrcSpanAnnA
-> ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ImportDecl { ideclExt :: XCImportDecl GhcPs
ideclExt       = XCImportDecl GhcPs
forall a. EpAnn a
noAnn,
                                ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText,
                                ideclName :: XRec GhcPs ModuleName
ideclName      = SrcSpanAnnA -> ModuleName -> GenLocated SrcSpanAnnA ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' ModuleName
pRELUDE_NAME,
                                ideclPkgQual :: Maybe StringLiteral
ideclPkgQual   = Maybe StringLiteral
forall a. Maybe a
Nothing,
                                ideclSource :: IsBootInterface
ideclSource    = IsBootInterface
NotBoot,
                                ideclSafe :: Bool
ideclSafe      = Bool
False,  -- Not a safe import
                                ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = ImportDeclQualifiedStyle
NotQualified,
                                ideclImplicit :: Bool
ideclImplicit  = Bool
True,   -- Implicit!
                                ideclAs :: Maybe (XRec GhcPs ModuleName)
ideclAs        = Maybe (XRec GhcPs ModuleName)
forall a. Maybe a
Nothing,
                                ideclHiding :: Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclHiding    = Maybe (Bool, XRec GhcPs [LIE GhcPs])
forall a. Maybe a
Nothing  }

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

-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
--
-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)
getOptionsFromFile :: DynFlags
                   -> FilePath            -- ^ Input file
                   -> IO [Located String] -- ^ Parsed options, if any.
getOptionsFromFile :: DynFlags -> String -> IO [Located String]
getOptionsFromFile DynFlags
dflags String
filename
    = IO Handle
-> (Handle -> IO ())
-> (Handle -> IO [Located String])
-> IO [Located String]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
              (String -> IOMode -> IO Handle
openBinaryFile String
filename IOMode
ReadMode)
              (Handle -> IO ()
hClose)
              (\Handle
handle -> do
                  [Located String]
opts <- ([Located Token] -> [Located String])
-> IO [Located Token] -> IO [Located String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags -> [Located Token] -> [Located String]
getOptions' DynFlags
dflags)
                               (ParserOpts -> String -> Handle -> IO [Located Token]
lazyGetToks (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags') String
filename Handle
handle)
                  [Located String] -> IO [Located String] -> IO [Located String]
forall a b. [a] -> b -> b
seqList [Located String]
opts (IO [Located String] -> IO [Located String])
-> IO [Located String] -> IO [Located String]
forall a b. (a -> b) -> a -> b
$ [Located String] -> IO [Located String]
forall (m :: * -> *) a. Monad m => a -> m a
return [Located String]
opts)
    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.
          dflags' :: DynFlags
dflags' = DynFlags -> GeneralFlag -> DynFlags
gopt_unset DynFlags
dflags GeneralFlag
Opt_Haddock

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

lazyGetToks :: ParserOpts -> FilePath -> Handle -> IO [Located Token]
lazyGetToks :: ParserOpts -> String -> Handle -> IO [Located Token]
lazyGetToks ParserOpts
popts String
filename Handle
handle = do
  StringBuffer
buf <- Handle -> Int -> IO StringBuffer
hGetStringBufferBlock Handle
handle Int
blockSize
  let prag_state :: PState
prag_state = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initPragState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc
  IO [Located Token] -> IO [Located Token]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [Located Token] -> IO [Located Token])
-> IO [Located Token] -> IO [Located Token]
forall a b. (a -> b) -> a -> b
$ Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
prag_state Bool
False Int
blockSize
 where
  loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1

  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state Bool
eof Int
size =
    case P (Located Token) -> PState -> ParseResult (Located Token)
forall a. P a -> PState -> ParseResult a
unP (Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False Located Token -> P (Located Token)
forall (m :: * -> *) a. Monad m => a -> m a
return) PState
state of
      POk PState
state' Located Token
t -> do
        -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())
        if StringBuffer -> Bool
atEnd (PState -> StringBuffer
buffer PState
state') Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
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 Handle -> PState -> Int -> IO [Located Token]
getMore Handle
handle PState
state Int
size
           else case Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
t of
                  Token
ITeof  -> [Located Token] -> IO [Located Token]
forall (m :: * -> *) a. Monad m => a -> m a
return [Located Token
t]
                  Token
_other -> do [Located Token]
rest <- Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state' Bool
eof Int
size
                               [Located Token] -> IO [Located Token]
forall (m :: * -> *) a. Monad m => a -> m a
return (Located Token
t Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Located Token]
rest)
      ParseResult (Located Token)
_ | Bool -> Bool
not Bool
eof   -> Handle -> PState -> Int -> IO [Located Token]
getMore Handle
handle PState
state Int
size
        | Bool
otherwise -> [Located Token] -> IO [Located Token]
forall (m :: * -> *) a. Monad m => a -> m a
return [SrcSpan -> Token -> Located Token
forall l e. l -> e -> GenLocated l e
L (PsSpan -> SrcSpan
mkSrcSpanPs (PState -> PsSpan
last_loc PState
state)) Token
ITeof]
                         -- parser assumes an ITeof sentinel at the end

  getMore :: Handle -> PState -> Int -> IO [Located Token]
  getMore :: Handle -> PState -> Int -> IO [Located Token]
getMore Handle
handle PState
state Int
size = do
     -- pprTrace "getMore" (text (show (buffer state))) (return ())
     let new_size :: Int
new_size = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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)
     StringBuffer
nextbuf <- Handle -> Int -> IO StringBuffer
hGetStringBufferBlock Handle
handle Int
new_size
     if (StringBuffer -> Int
len StringBuffer
nextbuf Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) then Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state Bool
True Int
new_size else do
       StringBuffer
newbuf <- StringBuffer -> StringBuffer -> IO StringBuffer
appendStringBuffers (PState -> StringBuffer
buffer PState
state) StringBuffer
nextbuf
       IO [Located Token] -> IO [Located Token]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [Located Token] -> IO [Located Token])
-> IO [Located Token] -> IO [Located Token]
forall a b. (a -> b) -> a -> b
$ Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state{buffer :: StringBuffer
buffer=StringBuffer
newbuf} Bool
False Int
new_size


getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]
getToks :: ParserOpts -> String -> StringBuffer -> [Located Token]
getToks ParserOpts
popts String
filename StringBuffer
buf = PState -> [Located Token]
lexAll PState
pstate
 where
  pstate :: PState
pstate = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initPragState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc
  loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1

  lexAll :: PState -> [Located Token]
lexAll PState
state = case P (Located Token) -> PState -> ParseResult (Located Token)
forall a. P a -> PState -> ParseResult a
unP (Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False Located Token -> P (Located Token)
forall (m :: * -> *) a. Monad m => a -> m a
return) PState
state of
                   POk PState
_      t :: Located Token
t@(L SrcSpan
_ Token
ITeof) -> [Located Token
t]
                   POk PState
state' Located Token
t -> Located Token
t Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: PState -> [Located Token]
lexAll PState
state'
                   ParseResult (Located Token)
_ -> [SrcSpan -> Token -> Located Token
forall l e. l -> e -> GenLocated l e
L (PsSpan -> SrcSpan
mkSrcSpanPs (PState -> PsSpan
last_loc PState
state)) Token
ITeof]


-- | 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.
getOptions :: DynFlags -> StringBuffer -> String -> [Located String]
getOptions DynFlags
dflags StringBuffer
buf String
filename
    = DynFlags -> [Located Token] -> [Located String]
getOptions' DynFlags
dflags (ParserOpts -> String -> StringBuffer -> [Located Token]
getToks (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) String
filename StringBuffer
buf)

-- 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'.
getOptions' :: DynFlags
            -> [Located Token]      -- Input buffer
            -> [Located String]     -- Options.
getOptions' :: DynFlags -> [Located Token] -> [Located String]
getOptions' DynFlags
dflags [Located Token]
toks
    = [Located Token] -> [Located String]
parseToks [Located Token]
toks
    where
          parseToks :: [Located Token] -> [Located String]
parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
              | IToptions_prag String
str <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
open
              , Token
ITclose_prag       <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
close
              = case String -> Either String [String]
toArgs String
str of
                  Left String
_err -> String -> SrcSpan -> [Located String]
forall a. String -> SrcSpan -> a
optionsParseError String
str (SrcSpan -> [Located String]) -> SrcSpan -> [Located String]
forall a b. (a -> b) -> a -> b
$   -- #15053
                                 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open) (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
close)
                  Right [String]
args -> (String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open)) [String]
args [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
++ [Located Token] -> [Located String]
parseToks [Located Token]
xs
          parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
              | ITinclude_prag String
str <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
open
              , Token
ITclose_prag       <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
close
              = (String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open)) [String
"-#include",String -> String
removeSpaces String
str] [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
++
                [Located Token] -> [Located String]
parseToks [Located Token]
xs
          parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
              | ITdocOptions String
str PsSpan
_ <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
open
              , Token
ITclose_prag       <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
close
              = (String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open)) [String
"-haddock-opts", String -> String
removeSpaces String
str]
                [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
++ [Located Token] -> [Located String]
parseToks [Located Token]
xs
          parseToks (Located Token
open:[Located Token]
xs)
              | Token
ITlanguage_prag <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
open
              = [Located Token] -> [Located String]
parseLanguage [Located Token]
xs
          parseToks (Located Token
comment:[Located Token]
xs) -- Skip over comments
              | Token -> Bool
isComment (Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
comment)
              = [Located Token] -> [Located String]
parseToks [Located Token]
xs
          parseToks [Located Token]
_ = []
          parseLanguage :: [Located Token] -> [Located String]
parseLanguage ((L SrcSpan
loc (ITconid FastString
fs)):[Located Token]
rest)
              = DynFlags -> Located FastString -> Located String
checkExtension DynFlags
dflags (SrcSpan -> FastString -> Located FastString
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc FastString
fs) Located String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
:
                case [Located Token]
rest of
                  (L SrcSpan
_loc Token
ITcomma):[Located Token]
more -> [Located Token] -> [Located String]
parseLanguage [Located Token]
more
                  (L SrcSpan
_loc Token
ITclose_prag):[Located Token]
more -> [Located Token] -> [Located String]
parseToks [Located Token]
more
                  (L SrcSpan
loc Token
_):[Located Token]
_ -> SrcSpan -> [Located String]
forall a. SrcSpan -> a
languagePragParseError SrcSpan
loc
                  [] -> String -> [Located String]
forall a. String -> a
panic String
"getOptions'.parseLanguage(1) went past eof token"
          parseLanguage (Located Token
tok:[Located Token]
_)
              = SrcSpan -> [Located String]
forall a. SrcSpan -> a
languagePragParseError (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
tok)
          parseLanguage []
              = String -> [Located String]
forall a. String -> a
panic String
"getOptions'.parseLanguage(2) went past eof token"

          isComment :: Token -> Bool
          isComment :: Token -> Bool
isComment Token
c =
            case Token
c of
              (ITlineComment {})     -> Bool
True
              (ITblockComment {})    -> Bool
True
              (ITdocCommentNext {})  -> Bool
True
              (ITdocCommentPrev {})  -> Bool
True
              (ITdocCommentNamed {}) -> Bool
True
              (ITdocSection {})      -> Bool
True
              Token
_                      -> Bool
False

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

-- | 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.
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
checkProcessArgsResult :: forall (m :: * -> *). MonadIO m => [Located String] -> m ()
checkProcessArgsResult [Located String]
flags
  = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Located String] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Located String]
flags) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SourceError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SourceError -> IO ()) -> SourceError -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> SourceError
mkSrcErr (ErrorMessages -> SourceError) -> ErrorMessages -> SourceError
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope DecoratedSDoc] -> ErrorMessages
forall a. [a] -> Bag a
listToBag ([MsgEnvelope DecoratedSDoc] -> ErrorMessages)
-> [MsgEnvelope DecoratedSDoc] -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ (Located String -> MsgEnvelope DecoratedSDoc)
-> [Located String] -> [MsgEnvelope DecoratedSDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> MsgEnvelope DecoratedSDoc
mkMsg [Located String]
flags
    where mkMsg :: Located String -> MsgEnvelope DecoratedSDoc
mkMsg (L SrcSpan
loc String
flag)
              = SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc (SDoc -> MsgEnvelope DecoratedSDoc)
-> SDoc -> MsgEnvelope DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
                  (String -> SDoc
text String
"unknown flag in  {-# OPTIONS_GHC #-} pragma:" SDoc -> SDoc -> SDoc
<+>
                   String -> SDoc
text String
flag)

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

checkExtension :: DynFlags -> Located FastString -> Located String
checkExtension :: DynFlags -> Located FastString -> Located String
checkExtension DynFlags
dflags (L SrcSpan
l FastString
ext)
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
  = if String
ext' String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
supported
    then SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (String
"-X"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ext')
    else DynFlags -> SrcSpan -> String -> Located String
forall a. DynFlags -> SrcSpan -> String -> a
unsupportedExtnError DynFlags
dflags SrcSpan
l String
ext'
  where
    ext' :: String
ext' = FastString -> String
unpackFS FastString
ext
    supported :: [String]
supported = ArchOS -> [String]
supportedLanguagesAndExtensions (ArchOS -> [String]) -> ArchOS -> [String]
forall a b. (a -> b) -> a -> b
$ Platform -> ArchOS
platformArchOS (Platform -> ArchOS) -> Platform -> ArchOS
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags

languagePragParseError :: SrcSpan -> a
languagePragParseError :: forall a. SrcSpan -> a
languagePragParseError SrcSpan
loc =
    SrcSpan -> SDoc -> a
forall a. SrcSpan -> SDoc -> a
throwErr SrcSpan
loc (SDoc -> a) -> SDoc -> a
forall a b. (a -> b) -> a -> b
$
       [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Cannot parse LANGUAGE pragma"
            , String -> SDoc
text String
"Expecting comma-separated list of language options,"
            , String -> SDoc
text String
"each starting with a capital letter"
            , Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]

unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
unsupportedExtnError :: forall a. DynFlags -> SrcSpan -> String -> a
unsupportedExtnError DynFlags
dflags SrcSpan
loc String
unsup =
    SrcSpan -> SDoc -> a
forall a. SrcSpan -> SDoc -> a
throwErr SrcSpan
loc (SDoc -> a) -> SDoc -> a
forall a b. (a -> b) -> a -> b
$
        String -> SDoc
text String
"Unsupported extension: " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
unsup SDoc -> SDoc -> SDoc
$$
        if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
suggestions then SDoc
Outputable.empty else String -> SDoc
text String
"Perhaps you meant" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
quotedListWithOr ((String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text [String]
suggestions)
  where
     supported :: [String]
supported = ArchOS -> [String]
supportedLanguagesAndExtensions (ArchOS -> [String]) -> ArchOS -> [String]
forall a b. (a -> b) -> a -> b
$ Platform -> ArchOS
platformArchOS (Platform -> ArchOS) -> Platform -> ArchOS
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
     suggestions :: [String]
suggestions = String -> [String] -> [String]
fuzzyMatch String
unsup [String]
supported


optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DecoratedSDoc
optionsErrorMsgs :: [String] -> [Located String] -> String -> Messages DecoratedSDoc
optionsErrorMsgs [String]
unhandled_flags [Located String]
flags_lines String
_filename
  = ErrorMessages -> Messages DecoratedSDoc
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (ErrorMessages -> Messages DecoratedSDoc)
-> ErrorMessages -> Messages DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope DecoratedSDoc] -> ErrorMessages
forall a. [a] -> Bag a
listToBag ((Located String -> MsgEnvelope DecoratedSDoc)
-> [Located String] -> [MsgEnvelope DecoratedSDoc]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> MsgEnvelope DecoratedSDoc
mkMsg [Located String]
unhandled_flags_lines)
  where unhandled_flags_lines :: [Located String]
        unhandled_flags_lines :: [Located String]
unhandled_flags_lines = [ SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L SrcSpan
l String
f
                                | String
f <- [String]
unhandled_flags
                                , L SrcSpan
l String
f' <- [Located String]
flags_lines
                                , String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
f' ]
        mkMsg :: Located String -> MsgEnvelope DecoratedSDoc
mkMsg (L SrcSpan
flagSpan String
flag) =
            SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
flagSpan (SDoc -> MsgEnvelope DecoratedSDoc)
-> SDoc -> MsgEnvelope DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
                    String -> SDoc
text String
"unknown flag in  {-# OPTIONS_GHC #-} pragma:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
flag

optionsParseError :: String -> SrcSpan -> a     -- #15053
optionsParseError :: forall a. String -> SrcSpan -> a
optionsParseError String
str SrcSpan
loc =
  SrcSpan -> SDoc -> a
forall a. SrcSpan -> SDoc -> a
throwErr SrcSpan
loc (SDoc -> a) -> SDoc -> a
forall a b. (a -> b) -> a -> b
$
      [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Error while parsing OPTIONS_GHC pragma."
           , String -> SDoc
text String
"Expecting whitespace-separated list of GHC options."
           , String -> SDoc
text String
"  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
           , String -> SDoc
text (String
"Input was: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str) ]

throwErr :: SrcSpan -> SDoc -> a                -- #15053
throwErr :: forall a. SrcSpan -> SDoc -> a
throwErr SrcSpan
loc SDoc
doc =
  SourceError -> a
forall a e. Exception e => e -> a
throw (SourceError -> a) -> SourceError -> a
forall a b. (a -> b) -> a -> b
$ ErrorMessages -> SourceError
mkSrcErr (ErrorMessages -> SourceError) -> ErrorMessages -> SourceError
forall a b. (a -> b) -> a -> b
$ MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a. a -> Bag a
unitBag (MsgEnvelope DecoratedSDoc -> ErrorMessages)
-> MsgEnvelope DecoratedSDoc -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc SDoc
doc