{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# 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.Types
import GHC.Parser           ( parseHeader )
import GHC.Parser.Lexer
import GHC.Data.FastString
import GHC.Hs
import GHC.Unit.Module
import GHC.Builtin.Names
import GHC.Data.StringBuffer
import GHC.Types.SrcLoc
import GHC.Driver.Session
import GHC.Utils.Error
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Data.Maybe
import GHC.Data.Bag         ( emptyBag, listToBag, unitBag )
import GHC.Utils.Monad
import GHC.Utils.Exception as Exception
import GHC.Types.Basic
import qualified GHC.LanguageExtensions as LangExt

import Control.Monad
import System.IO
import System.IO.Unsafe
import Data.List

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

-- | Parse the imports of a source file.
--
-- Throws a 'SourceError' if parsing fails.
getImports :: DynFlags
           -> 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
               ErrorMessages
               ([(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 :: DynFlags
-> StringBuffer
-> String
-> String
-> IO
     (Either
        ErrorMessages
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
getImports DynFlags
dflags 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 (DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
dflags StringBuffer
buf RealSrcLoc
loc) of
    PFailed PState
pst ->
        -- assuming we're not logging warnings here as per below
      Either
  ErrorMessages
  ([(Maybe FastString, Located ModuleName)],
   [(Maybe FastString, Located ModuleName)], Located ModuleName)
-> IO
     (Either
        ErrorMessages
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   ErrorMessages
   ([(Maybe FastString, Located ModuleName)],
    [(Maybe FastString, Located ModuleName)], Located ModuleName)
 -> IO
      (Either
         ErrorMessages
         ([(Maybe FastString, Located ModuleName)],
          [(Maybe FastString, Located ModuleName)], Located ModuleName)))
-> Either
     ErrorMessages
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
-> IO
     (Either
        ErrorMessages
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
forall a b. (a -> b) -> a -> b
$ ErrorMessages
-> Either
     ErrorMessages
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
forall a b. a -> Either a b
Left (ErrorMessages
 -> Either
      ErrorMessages
      ([(Maybe FastString, Located ModuleName)],
       [(Maybe FastString, Located ModuleName)], Located ModuleName))
-> ErrorMessages
-> Either
     ErrorMessages
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
forall a b. (a -> b) -> a -> b
$ PState -> DynFlags -> ErrorMessages
getErrorMessages PState
pst DynFlags
dflags
    POk PState
pst Located HsModule
rdr_module -> (([(Maybe FastString, Located ModuleName)],
  [(Maybe FastString, Located ModuleName)], Located ModuleName)
 -> Either
      ErrorMessages
      ([(Maybe FastString, Located ModuleName)],
       [(Maybe FastString, Located ModuleName)], Located ModuleName))
-> IO
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
-> IO
     (Either
        ErrorMessages
        ([(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
     ErrorMessages
     ([(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
         ErrorMessages
         ([(Maybe FastString, Located ModuleName)],
          [(Maybe FastString, Located ModuleName)], Located ModuleName)))
-> IO
     ([(Maybe FastString, Located ModuleName)],
      [(Maybe FastString, Located ModuleName)], Located ModuleName)
-> IO
     (Either
        ErrorMessages
        ([(Maybe FastString, Located ModuleName)],
         [(Maybe FastString, Located ModuleName)], Located ModuleName))
forall a b. (a -> b) -> a -> b
$ do
      let _ms :: (ErrorMessages, ErrorMessages)
_ms@(ErrorMessages
_warns, ErrorMessages
errs) = PState -> DynFlags -> (ErrorMessages, ErrorMessages)
getMessages PState
pst DynFlags
dflags
      -- don't log warnings: they'll be reported when we parse the file
      -- for real.  See #2500.
          ms :: (ErrorMessages, ErrorMessages)
ms = (ErrorMessages
forall a. Bag a
emptyBag, ErrorMessages
errs)
      -- logWarnings warns
      if DynFlags -> (ErrorMessages, ErrorMessages) -> Bool
errorsFound DynFlags
dflags (ErrorMessages, ErrorMessages)
ms
        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 ErrorMessages
errs
        else
          let   hsmod :: HsModule
hsmod = Located HsModule -> HsModule
forall l e. GenLocated l e -> e
unLoc Located HsModule
rdr_module
                mb_mod :: Maybe (Located ModuleName)
mb_mod = HsModule -> Maybe (Located 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 :: Located ModuleName
mod = Maybe (Located ModuleName)
mb_mod Maybe (Located ModuleName)
-> Located ModuleName -> Located ModuleName
forall a. Maybe a -> a -> a
`orElse` SrcSpan -> ModuleName -> Located ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
main_loc ModuleName
mAIN_NAME
                ([LImportDecl GhcPs]
src_idecls, [LImportDecl GhcPs]
ord_idecls) = (LImportDecl GhcPs -> Bool)
-> [LImportDecl GhcPs]
-> ([LImportDecl GhcPs], [LImportDecl GhcPs])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (IsBootInterface -> Bool)
-> (LImportDecl GhcPs -> IsBootInterface)
-> LImportDecl GhcPs
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> IsBootInterface
forall pass. ImportDecl pass -> IsBootInterface
ideclSource (ImportDecl GhcPs -> IsBootInterface)
-> (LImportDecl GhcPs -> ImportDecl GhcPs)
-> LImportDecl GhcPs
-> IsBootInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcPs -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc) [LImportDecl GhcPs]
imps

               -- GHC.Prim doesn't exist physically, so don't go looking for it.
                ordinary_imps :: [LImportDecl GhcPs]
ordinary_imps = (LImportDecl GhcPs -> Bool)
-> [LImportDecl GhcPs] -> [LImportDecl 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)
-> (LImportDecl GhcPs -> ModuleName) -> LImportDecl GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc
                                        (Located ModuleName -> ModuleName)
-> (LImportDecl GhcPs -> Located ModuleName)
-> LImportDecl GhcPs
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> Located ModuleName
forall pass. ImportDecl pass -> Located ModuleName
ideclName (ImportDecl GhcPs -> Located ModuleName)
-> (LImportDecl GhcPs -> ImportDecl GhcPs)
-> LImportDecl GhcPs
-> Located ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LImportDecl GhcPs -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc)
                                       [LImportDecl GhcPs]
ord_idecls

                implicit_prelude :: Bool
implicit_prelude = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitPrelude DynFlags
dflags
                implicit_imports :: [LImportDecl GhcPs]
implicit_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports (Located ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc Located 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), ImportDecl pass -> Located ModuleName
forall pass. ImportDecl pass -> Located 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 ((LImportDecl GhcPs -> (Maybe FastString, Located ModuleName))
-> [LImportDecl GhcPs] -> [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map LImportDecl GhcPs -> (Maybe FastString, Located ModuleName)
forall {l} {pass}.
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport [LImportDecl GhcPs]
src_idecls,
                      (LImportDecl GhcPs -> (Maybe FastString, Located ModuleName))
-> [LImportDecl GhcPs] -> [(Maybe FastString, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map LImportDecl GhcPs -> (Maybe FastString, Located ModuleName)
forall {l} {pass}.
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport ([LImportDecl GhcPs]
implicit_imports [LImportDecl GhcPs] -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LImportDecl GhcPs]
ordinary_imps),
                      Located 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
       = [()] -> Bool
forall a. [a] -> Bool
notNull [ () | L SrcSpan
_ (ImportDecl { ideclName :: forall pass. ImportDecl pass -> Located ModuleName
ideclName = Located ModuleName
mod
                                        , ideclPkgQual :: forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual = Maybe StringLiteral
Nothing })
                          <- [LImportDecl GhcPs]
import_decls
                      , Located ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc Located ModuleName
mod ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME ]

      preludeImportDecl :: LImportDecl GhcPs
      preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
        = SrcSpan -> ImportDecl GhcPs -> LImportDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (ImportDecl GhcPs -> LImportDecl GhcPs)
-> ImportDecl GhcPs -> LImportDecl GhcPs
forall a b. (a -> b) -> a -> b
$ ImportDecl :: forall pass.
XCImportDecl pass
-> SourceText
-> Located ModuleName
-> Maybe StringLiteral
-> IsBootInterface
-> Bool
-> ImportDeclQualifiedStyle
-> Bool
-> Maybe (Located ModuleName)
-> Maybe (Bool, Located [LIE pass])
-> ImportDecl pass
ImportDecl { ideclExt :: XCImportDecl GhcPs
ideclExt       = NoExtField
XCImportDecl GhcPs
noExtField,
                               ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText,
                               ideclName :: Located ModuleName
ideclName      = SrcSpan -> ModuleName -> Located ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpan
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 (Located ModuleName)
ideclAs        = Maybe (Located ModuleName)
forall a. Maybe a
Nothing,
                               ideclHiding :: Maybe (Bool, Located [LIE GhcPs])
ideclHiding    = Maybe (Bool, Located [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)
                               (DynFlags -> String -> Handle -> IO [Located Token]
lazyGetToks 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 :: DynFlags -> FilePath -> Handle -> IO [Located Token]
lazyGetToks :: DynFlags -> String -> Handle -> IO [Located Token]
lazyGetToks DynFlags
dflags String
filename Handle
handle = do
  StringBuffer
buf <- Handle -> Int -> IO StringBuffer
hGetStringBufferBlock Handle
handle Int
blockSize
  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 (DynFlags -> StringBuffer -> RealSrcLoc -> PState
pragState DynFlags
dflags StringBuffer
buf RealSrcLoc
loc) 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 = do
    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 :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks :: DynFlags -> String -> StringBuffer -> [Located Token]
getToks DynFlags
dflags String
filename StringBuffer
buf = PState -> [Located Token]
lexAll (DynFlags -> StringBuffer -> RealSrcLoc -> PState
pragState DynFlags
dflags StringBuffer
buf RealSrcLoc
loc)
 where
  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 (DynFlags -> String -> StringBuffer -> [Located Token]
getToks 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 -> DynFlags -> SrcSpan -> [Located String]
forall a. String -> DynFlags -> SrcSpan -> a
optionsParseError String
str DynFlags
dflags (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 <- 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]
_ -> DynFlags -> SrcSpan -> [Located String]
forall a. DynFlags -> SrcSpan -> a
languagePragParseError DynFlags
dflags SrcSpan
loc
                  [] -> String -> [Located String]
forall a. String -> a
panic String
"getOptions'.parseLanguage(1) went past eof token"
          parseLanguage (Located Token
tok:[Located Token]
_)
              = DynFlags -> SrcSpan -> [Located String]
forall a. DynFlags -> SrcSpan -> a
languagePragParseError DynFlags
dflags (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 => DynFlags -> [Located String] -> m ()
checkProcessArgsResult :: forall (m :: * -> *).
MonadIO m =>
DynFlags -> [Located String] -> m ()
checkProcessArgsResult DynFlags
dflags [Located String]
flags
  = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Located String] -> Bool
forall a. [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
$ [ErrMsg] -> ErrorMessages
forall a. [a] -> Bag a
listToBag ([ErrMsg] -> ErrorMessages) -> [ErrMsg] -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ (Located String -> ErrMsg) -> [Located String] -> [ErrMsg]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> ErrMsg
mkMsg [Located String]
flags
    where mkMsg :: Located String -> ErrMsg
mkMsg (L SrcSpan
loc String
flag)
              = DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
loc (MsgDoc -> ErrMsg) -> MsgDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                  (String -> MsgDoc
text String
"unknown flag in  {-# OPTIONS_GHC #-} pragma:" MsgDoc -> MsgDoc -> MsgDoc
<+>
                   String -> MsgDoc
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 = PlatformMini -> [String]
supportedLanguagesAndExtensions (PlatformMini -> [String]) -> PlatformMini -> [String]
forall a b. (a -> b) -> a -> b
$ Platform -> PlatformMini
platformMini (Platform -> PlatformMini) -> Platform -> PlatformMini
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags

languagePragParseError :: DynFlags -> SrcSpan -> a
languagePragParseError :: forall a. DynFlags -> SrcSpan -> a
languagePragParseError DynFlags
dflags SrcSpan
loc =
    DynFlags -> SrcSpan -> MsgDoc -> a
forall a. DynFlags -> SrcSpan -> MsgDoc -> a
throwErr DynFlags
dflags SrcSpan
loc (MsgDoc -> a) -> MsgDoc -> a
forall a b. (a -> b) -> a -> b
$
       [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Cannot parse LANGUAGE pragma"
            , String -> MsgDoc
text String
"Expecting comma-separated list of language options,"
            , String -> MsgDoc
text String
"each starting with a capital letter"
            , Int -> MsgDoc -> MsgDoc
nest Int
2 (String -> MsgDoc
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 =
    DynFlags -> SrcSpan -> MsgDoc -> a
forall a. DynFlags -> SrcSpan -> MsgDoc -> a
throwErr DynFlags
dflags SrcSpan
loc (MsgDoc -> a) -> MsgDoc -> a
forall a b. (a -> b) -> a -> b
$
        String -> MsgDoc
text String
"Unsupported extension: " MsgDoc -> MsgDoc -> MsgDoc
<> String -> MsgDoc
text String
unsup MsgDoc -> MsgDoc -> MsgDoc
$$
        if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
suggestions then MsgDoc
Outputable.empty else String -> MsgDoc
text String
"Perhaps you meant" MsgDoc -> MsgDoc -> MsgDoc
<+> [MsgDoc] -> MsgDoc
quotedListWithOr ((String -> MsgDoc) -> [String] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> MsgDoc
text [String]
suggestions)
  where
     supported :: [String]
supported = PlatformMini -> [String]
supportedLanguagesAndExtensions (PlatformMini -> [String]) -> PlatformMini -> [String]
forall a b. (a -> b) -> a -> b
$ Platform -> PlatformMini
platformMini (Platform -> PlatformMini) -> Platform -> PlatformMini
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
     suggestions :: [String]
suggestions = String -> [String] -> [String]
fuzzyMatch String
unsup [String]
supported


optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
optionsErrorMsgs :: DynFlags
-> [String]
-> [Located String]
-> String
-> (ErrorMessages, ErrorMessages)
optionsErrorMsgs DynFlags
dflags [String]
unhandled_flags [Located String]
flags_lines String
_filename
  = (ErrorMessages
forall a. Bag a
emptyBag, [ErrMsg] -> ErrorMessages
forall a. [a] -> Bag a
listToBag ((Located String -> ErrMsg) -> [Located String] -> [ErrMsg]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> ErrMsg
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 -> ErrMsg
mkMsg (L SrcSpan
flagSpan String
flag) =
            DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
GHC.Utils.Error.mkPlainErrMsg DynFlags
dflags SrcSpan
flagSpan (MsgDoc -> ErrMsg) -> MsgDoc -> ErrMsg
forall a b. (a -> b) -> a -> b
$
                    String -> MsgDoc
text String
"unknown flag in  {-# OPTIONS_GHC #-} pragma:" MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
flag

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

throwErr :: DynFlags -> SrcSpan -> SDoc -> a                -- #15053
throwErr :: forall a. DynFlags -> SrcSpan -> MsgDoc -> a
throwErr DynFlags
dflags SrcSpan
loc MsgDoc
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
$ ErrMsg -> ErrorMessages
forall a. a -> Bag a
unitBag (ErrMsg -> ErrorMessages) -> ErrMsg -> ErrorMessages
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> MsgDoc -> ErrMsg
mkPlainErrMsg DynFlags
dflags SrcSpan
loc MsgDoc
doc