{-# 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
   , toArgs
   , checkProcessArgsResult
   )
where

import GHC.Prelude

import GHC.Data.Bag

import GHC.Driver.Errors.Types -- Unfortunate, needed due to the fact we throw exceptions!

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

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

import GHC.Types.Error
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.SourceText
import GHC.Types.PkgQual

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

import GHC.Data.StringBuffer
import GHC.Data.Maybe
import GHC.Data.FastString
import qualified GHC.Data.Strict as Strict

import Control.Monad
import System.IO
import System.IO.Unsafe
import Data.List (partition)
import Data.Char (isSpace)
import Text.ParserCombinators.ReadP (readP_to_S, gather)
import Text.ParserCombinators.ReadPrec (readPrec_to_P)
import Text.Read (readPrec)

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

-- | 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
               (Messages PsMessage)
               ([(RawPkgQual, Located ModuleName)],
                [(RawPkgQual, Located ModuleName)],
                Bool, -- Is GHC.Prim imported or not
                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
        (Messages PsMessage)
        ([(RawPkgQual, Located ModuleName)],
         [(RawPkgQual, Located ModuleName)], Bool, 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 forall a. P a -> PState -> ParseResult a
unP P (Located (HsModule GhcPs))
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
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ PState -> Messages PsMessage
getPsErrorMessages PState
pst
    POk PState
pst Located (HsModule GhcPs)
rdr_module -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ do
      let (Messages PsMessage
_warns, Messages PsMessage
errs) = PState -> (Messages PsMessage, Messages PsMessage)
getPsMessages PState
pst
      -- don't log warnings: they'll be reported when we parse the file
      -- for real.  See #2500.
      if Bool -> Bool
not (forall e. Messages e -> Bool
isEmptyMessages Messages PsMessage
errs)
        then forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsMessage -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsMessage
errs)
        else
          let   hsmod :: HsModule GhcPs
hsmod = forall l e. GenLocated l e -> e
unLoc Located (HsModule GhcPs)
rdr_module
                mb_mod :: Maybe (XRec GhcPs ModuleName)
mb_mod = forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName HsModule GhcPs
hsmod
                imps :: [LImportDecl GhcPs]
imps = forall p. HsModule p -> [LImportDecl p]
hsmodImports HsModule GhcPs
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 (XRec GhcPs ModuleName)
mb_mod forall a. Maybe a -> a -> a
`orElse` forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
main_loc) ModuleName
mAIN_NAME
                ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> IsBootInterface
ideclSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LImportDecl GhcPs]
imps

               -- GHC.Prim doesn't exist physically, so don't go looking for it.
                ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ghc_prim_import)
                  = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName Module
gHC_PRIM) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
                                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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)
-> (ImportDeclPkgQual pass, Located ModuleName)
convImport (L l
_ ImportDecl pass
i) = (forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl pass
i, forall a e. LocatedAn a e -> Located e
reLoc forall a b. (a -> b) -> a -> b
$ forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
i)
              in
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (ImportDeclPkgQual pass, Located ModuleName)
convImport [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls
                     , forall a b. (a -> b) -> [a] -> [b]
map forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (ImportDeclPkgQual pass, Located ModuleName)
convImport ([LImportDecl GhcPs]
implicit_imports forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps)
                     , Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ghc_prim_import)
                     , 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 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {pass} {l} {l}.
(XRec pass ModuleName ~ GenLocated l ModuleName,
 ImportDeclPkgQual pass ~ RawPkgQual) =>
GenLocated l (ImportDecl pass) -> Bool
is_prelude_import [LImportDecl GhcPs]
import_decls

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


      loc' :: SrcSpanAnnA
loc' = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
      preludeImportDecl :: LImportDecl GhcPs
      preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
        = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' forall a b. (a -> b) -> a -> b
$ ImportDecl { ideclExt :: XCImportDecl GhcPs
ideclExt       = XImportDeclPass
                                                    { ideclAnn :: EpAnn EpAnnImportDecl
ideclAnn = forall a. EpAnn a
noAnn
                                                    , ideclSourceText :: SourceText
ideclSourceText = SourceText
NoSourceText
                                                    , ideclImplicit :: Bool
ideclImplicit  = Bool
True   -- Implicit!
                                                    },
                                ideclName :: XRec GhcPs ModuleName
ideclName      = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' ModuleName
pRELUDE_NAME,
                                ideclPkgQual :: ImportDeclPkgQual GhcPs
ideclPkgQual   = RawPkgQual
NoRawPkgQual,
                                ideclSource :: IsBootInterface
ideclSource    = IsBootInterface
NotBoot,
                                ideclSafe :: Bool
ideclSafe      = Bool
False,  -- Not a safe import
                                ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = ImportDeclQualifiedStyle
NotQualified,
                                ideclAs :: Maybe (XRec GhcPs ModuleName)
ideclAs        = forall a. Maybe a
Nothing,
                                ideclImportList :: Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
ideclImportList = 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 :: ParserOpts
                   -> FilePath            -- ^ Input file
                   -> IO (Messages PsMessage, [Located String]) -- ^ Parsed options, if any.
getOptionsFromFile :: ParserOpts -> String -> IO (Messages PsMessage, [Located String])
getOptionsFromFile ParserOpts
opts String
filename
    = 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
                  (Messages PsMessage
warns, [Located String]
opts) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParserOpts
-> [Located Token] -> (Messages PsMessage, [Located String])
getOptions' ParserOpts
opts)
                               (ParserOpts -> String -> Handle -> IO [Located Token]
lazyGetToks ParserOpts
opts' String
filename Handle
handle)
                  forall a b. [a] -> b -> b
seqList [Located String]
opts
                    forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> b -> b
seqList (forall a. Bag a -> [a]
bagToList forall a b. (a -> b) -> a -> b
$ forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages PsMessage
warns)
                    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (Messages PsMessage
warns, [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.
          opts' :: ParserOpts
opts' = ParserOpts -> ParserOpts
disableHaddock ParserOpts
opts

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
  forall a. IO a -> IO a
unsafeInterleaveIO 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 forall a. P a -> PState -> ParseResult a
unP (forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False 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 forall l e. GenLocated l e -> e
unLoc Located Token
t of
                  Token
ITeof  -> 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
                               forall (m :: * -> *) a. Monad m => a -> m a
return (Located Token
t 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return [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 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 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
       forall a. IO a -> IO a
unsafeInterleaveIO 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 forall a. P a -> PState -> ParseResult a
unP (forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False 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 forall a. a -> [a] -> [a]
: PState -> [Located Token]
lexAll PState
state'
                   ParseResult (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 :: ParserOpts
           -> StringBuffer -- ^ Input Buffer
           -> FilePath     -- ^ Source filename.  Used for location info.
           -> (Messages PsMessage,[Located String]) -- ^ warnings and parsed options.
getOptions :: ParserOpts
-> StringBuffer -> String -> (Messages PsMessage, [Located String])
getOptions ParserOpts
opts StringBuffer
buf String
filename
    = ParserOpts
-> [Located Token] -> (Messages PsMessage, [Located String])
getOptions' ParserOpts
opts (ParserOpts -> String -> StringBuffer -> [Located Token]
getToks ParserOpts
opts 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' :: ParserOpts
            -> [Located Token]      -- Input buffer
            -> (Messages PsMessage,[Located String])     -- Options.
getOptions' :: ParserOpts
-> [Located Token] -> (Messages PsMessage, [Located String])
getOptions' ParserOpts
opts [Located Token]
toks
    = [Located Token] -> (Messages PsMessage, [Located String])
parseToks [Located Token]
toks
    where
          parseToks :: [Located Token] -> (Messages PsMessage, [Located String])
parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
              | IToptions_prag String
str <- forall l e. GenLocated l e -> e
unLoc Located Token
open
              , Token
ITclose_prag       <- forall l e. GenLocated l e -> e
unLoc Located Token
close
              = case RealSrcLoc -> String -> Either String [Located String]
toArgs RealSrcLoc
starting_loc String
str of
                  Left String
_err -> forall a. String -> SrcSpan -> a
optionsParseError String
str forall a b. (a -> b) -> a -> b
$   -- #15053
                                 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (forall l e. GenLocated l e -> l
getLoc Located Token
open) (forall l e. GenLocated l e -> l
getLoc Located Token
close)
                  Right [Located String]
args -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Located String]
args forall a. [a] -> [a] -> [a]
++) ([Located Token] -> (Messages PsMessage, [Located String])
parseToks [Located Token]
xs)
            where
              src_span :: SrcSpan
src_span      = forall l e. GenLocated l e -> l
getLoc Located Token
open
              real_src_span :: RealSrcSpan
real_src_span = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"getOptions'" (SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan SrcSpan
src_span)
              starting_loc :: RealSrcLoc
starting_loc  = RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
real_src_span
          parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
              | ITinclude_prag String
str <- forall l e. GenLocated l e -> e
unLoc Located Token
open
              , Token
ITclose_prag       <- forall l e. GenLocated l e -> e
unLoc Located Token
close
              = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc Located Token
open)) [String
"-#include",String -> String
removeSpaces String
str] forall a. [a] -> [a] -> [a]
++)
                     ([Located Token] -> (Messages PsMessage, [Located String])
parseToks [Located Token]
xs)
          parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
              | ITdocOptions String
str PsSpan
_ <- forall l e. GenLocated l e -> e
unLoc Located Token
open
              , Token
ITclose_prag       <- forall l e. GenLocated l e -> e
unLoc Located Token
close
              = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc Located Token
open)) [String
"-haddock-opts", String -> String
removeSpaces String
str] forall a. [a] -> [a] -> [a]
++)
                     ([Located Token] -> (Messages PsMessage, [Located String])
parseToks [Located Token]
xs)
          parseToks (Located Token
open:[Located Token]
xs)
              | Token
ITlanguage_prag <- forall l e. GenLocated l e -> e
unLoc Located Token
open
              = [Located Token] -> (Messages PsMessage, [Located String])
parseLanguage [Located Token]
xs
          parseToks (Located Token
comment:[Located Token]
xs) -- Skip over comments
              | Token -> Bool
isComment (forall l e. GenLocated l e -> e
unLoc Located Token
comment)
              = [Located Token] -> (Messages PsMessage, [Located String])
parseToks [Located Token]
xs
          -- At the end of the header, warn about all the misplaced pragmas
          parseToks [Located Token]
xs = (forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Located Token -> Maybe (Messages PsMessage)
mkMessage [Located Token]
xs ,[])

          parseLanguage :: [Located Token] -> (Messages PsMessage, [Located String])
parseLanguage ((L SrcSpan
loc (ITconid FastString
fs)):[Located Token]
rest)
              = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParserOpts -> Located FastString -> Located String
checkExtension ParserOpts
opts (forall l e. l -> e -> GenLocated l e
L SrcSpan
loc FastString
fs) forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$
                case [Located Token]
rest of
                  (L SrcSpan
_loc Token
ITcomma):[Located Token]
more -> [Located Token] -> (Messages PsMessage, [Located String])
parseLanguage [Located Token]
more
                  (L SrcSpan
_loc Token
ITclose_prag):[Located Token]
more -> [Located Token] -> (Messages PsMessage, [Located String])
parseToks [Located Token]
more
                  (L SrcSpan
loc Token
_):[Located Token]
_ -> forall a. SrcSpan -> a
languagePragParseError SrcSpan
loc
                  [] -> forall a. HasCallStack => String -> a
panic String
"getOptions'.parseLanguage(1) went past eof token"
          parseLanguage (Located Token
tok:[Located Token]
_)
              = forall a. SrcSpan -> a
languagePragParseError (forall l e. GenLocated l e -> l
getLoc Located Token
tok)
          parseLanguage []
              = forall a. HasCallStack => String -> a
panic String
"getOptions'.parseLanguage(2) went past eof token"

          -- Warn for all the misplaced pragmas
          mkMessage :: Located Token -> Maybe (Messages PsMessage)
          mkMessage :: Located Token -> Maybe (Messages PsMessage)
mkMessage (L SrcSpan
loc Token
token)
            | IToptions_prag String
_ <- Token
token
            = forall a. a -> Maybe a
Just (forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
loc (FileHeaderPragmaType -> PsMessage
PsWarnMisplacedPragma FileHeaderPragmaType
OptionsPrag))
            | ITinclude_prag String
_ <- Token
token
            = forall a. a -> Maybe a
Just (forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
loc (FileHeaderPragmaType -> PsMessage
PsWarnMisplacedPragma FileHeaderPragmaType
IncludePrag))
            | ITdocOptions String
_ PsSpan
_ <- Token
token
            = forall a. a -> Maybe a
Just (forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
loc (FileHeaderPragmaType -> PsMessage
PsWarnMisplacedPragma FileHeaderPragmaType
DocOptionsPrag))
            | Token
ITlanguage_prag <- Token
token
            = forall a. a -> Maybe a
Just (forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
loc (FileHeaderPragmaType -> PsMessage
PsWarnMisplacedPragma FileHeaderPragmaType
LanguagePrag))
            | Bool
otherwise = forall a. Maybe a
Nothing
            where diag_opts :: DiagOpts
diag_opts = ParserOpts -> DiagOpts
pDiagOpts ParserOpts
opts

          isComment :: Token -> Bool
          isComment :: Token -> Bool
isComment Token
c =
            case Token
c of
              (ITlineComment {})  -> Bool
True
              (ITblockComment {}) -> Bool
True
              (ITdocComment {})   -> Bool
True
              Token
_                   -> Bool
False

toArgs :: RealSrcLoc
       -> String -> Either String   -- Error
                           [Located String] -- Args
toArgs :: RealSrcLoc -> String -> Either String [Located String]
toArgs RealSrcLoc
starting_loc String
orig_str
    = let (RealSrcLoc
after_spaces_loc, String
after_spaces_str) = RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces RealSrcLoc
starting_loc String
orig_str in
      case String
after_spaces_str of
      Char
'[':String
after_bracket ->
        let after_bracket_loc :: RealSrcLoc
after_bracket_loc = RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
after_spaces_loc Char
'['
            (RealSrcLoc
after_bracket_spaces_loc, String
after_bracket_spaces_str)
              = RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces RealSrcLoc
after_bracket_loc String
after_bracket in
        case String
after_bracket_spaces_str of
          Char
']':String
rest | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
rest -> forall a b. b -> Either a b
Right []
          String
_ -> RealSrcLoc -> String -> Either String [Located String]
readAsList RealSrcLoc
after_bracket_spaces_loc String
after_bracket_spaces_str

      String
_ -> RealSrcLoc -> String -> Either String [Located String]
toArgs' RealSrcLoc
after_spaces_loc String
after_spaces_str
 where
  consume_spaces :: RealSrcLoc -> String -> (RealSrcLoc, String)
  consume_spaces :: RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces RealSrcLoc
loc [] = (RealSrcLoc
loc, [])
  consume_spaces RealSrcLoc
loc (Char
c:String
cs)
    | Char -> Bool
isSpace Char
c = RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
loc Char
c) String
cs
    | Bool
otherwise = (RealSrcLoc
loc, Char
cforall a. a -> [a] -> [a]
:String
cs)

  break_with_loc :: (Char -> Bool) -> RealSrcLoc -> String
                 -> (String, RealSrcLoc, String)  -- location is start of second string
  break_with_loc :: (Char -> Bool)
-> RealSrcLoc -> String -> (String, RealSrcLoc, String)
break_with_loc Char -> Bool
p = String -> RealSrcLoc -> String -> (String, RealSrcLoc, String)
go []
    where
      go :: String -> RealSrcLoc -> String -> (String, RealSrcLoc, String)
go String
reversed_acc RealSrcLoc
loc [] = (forall a. [a] -> [a]
reverse String
reversed_acc, RealSrcLoc
loc, [])
      go String
reversed_acc RealSrcLoc
loc (Char
c:String
cs)
        | Char -> Bool
p Char
c       = (forall a. [a] -> [a]
reverse String
reversed_acc, RealSrcLoc
loc, Char
cforall a. a -> [a] -> [a]
:String
cs)
        | Bool
otherwise = String -> RealSrcLoc -> String -> (String, RealSrcLoc, String)
go (Char
cforall a. a -> [a] -> [a]
:String
reversed_acc) (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
loc Char
c) String
cs

  advance_src_loc_many :: RealSrcLoc -> String -> RealSrcLoc
  advance_src_loc_many :: RealSrcLoc -> String -> RealSrcLoc
advance_src_loc_many = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc

  locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a
  locate :: forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
begin RealSrcLoc
end a
x = forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
begin RealSrcLoc
end) forall a. Maybe a
Strict.Nothing) a
x

  toArgs' :: RealSrcLoc -> String -> Either String [Located String]
  -- Remove outer quotes:
  -- > toArgs' "\"foo\" \"bar baz\""
  -- Right ["foo", "bar baz"]
  --
  -- Keep inner quotes:
  -- > toArgs' "-DFOO=\"bar baz\""
  -- Right ["-DFOO=\"bar baz\""]
  toArgs' :: RealSrcLoc -> String -> Either String [Located String]
toArgs' RealSrcLoc
loc String
s =
    let (RealSrcLoc
after_spaces_loc, String
after_spaces_str) = RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces RealSrcLoc
loc String
s in
    case String
after_spaces_str of
      [] -> forall a b. b -> Either a b
Right []
      Char
'"' : String
_ -> do
        -- readAsString removes outer quotes
        (String
arg, RealSrcLoc
new_loc, String
rest) <- RealSrcLoc -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
after_spaces_loc String
after_spaces_str
        String -> Either String ()
check_for_space String
rest
        (forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
new_loc String
argforall a. a -> [a] -> [a]
:)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RealSrcLoc -> String -> Either String [Located String]
toArgs' RealSrcLoc
new_loc String
rest
      String
_ -> case (Char -> Bool)
-> RealSrcLoc -> String -> (String, RealSrcLoc, String)
break_with_loc (Char -> Bool
isSpace forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (forall a. Eq a => a -> a -> Bool
== Char
'"')) RealSrcLoc
after_spaces_loc String
after_spaces_str of
            (String
argPart1, RealSrcLoc
loc2, s'' :: String
s''@(Char
'"':String
_)) -> do
                (String
argPart2, RealSrcLoc
loc3, String
rest) <- RealSrcLoc -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
loc2 String
s''
                String -> Either String ()
check_for_space String
rest
                -- show argPart2 to keep inner quotes
                (forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
loc3 (String
argPart1 forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
argPart2)forall a. a -> [a] -> [a]
:)
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RealSrcLoc -> String -> Either String [Located String]
toArgs' RealSrcLoc
loc3 String
rest
            (String
arg, RealSrcLoc
loc2, String
s'') -> (forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
loc2 String
argforall a. a -> [a] -> [a]
:)
                                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RealSrcLoc -> String -> Either String [Located String]
toArgs' RealSrcLoc
loc2 String
s''

  check_for_space :: String -> Either String ()
  check_for_space :: String -> Either String ()
check_for_space [] = forall a b. b -> Either a b
Right ()
  check_for_space (Char
c:String
_)
    | Char -> Bool
isSpace Char
c = forall a b. b -> Either a b
Right ()
    | Bool
otherwise = forall a b. a -> Either a b
Left (String
"Whitespace expected after string in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
orig_str)

  reads_with_consumed :: Read a => String
                      -> [((String, a), String)]
                        -- ((consumed string, parsed result), remainder of input)
  reads_with_consumed :: forall a. Read a => String -> [((String, a), String)]
reads_with_consumed = forall a. ReadP a -> ReadS a
readP_to_S (forall a. ReadP a -> ReadP (String, a)
gather (forall a. ReadPrec a -> Int -> ReadP a
readPrec_to_P forall a. Read a => ReadPrec a
readPrec Int
0))

  readAsString :: RealSrcLoc
               -> String
               -> Either String (String, RealSrcLoc, String)
  readAsString :: RealSrcLoc -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
loc String
s = case forall a. Read a => String -> [((String, a), String)]
reads_with_consumed String
s of
                [((String
consumed, String
arg), String
rest)] ->
                    forall a b. b -> Either a b
Right (String
arg, RealSrcLoc -> String -> RealSrcLoc
advance_src_loc_many RealSrcLoc
loc String
consumed, String
rest)
                [((String, String), String)]
_ ->
                    forall a b. a -> Either a b
Left (String
"Couldn't read " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s forall a. [a] -> [a] -> [a]
++ String
" as String")

   -- input has had the '[' stripped off
  readAsList :: RealSrcLoc -> String -> Either String [Located String]
  readAsList :: RealSrcLoc -> String -> Either String [Located String]
readAsList RealSrcLoc
loc String
s = do
    let (RealSrcLoc
after_spaces_loc, String
after_spaces_str) = RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces RealSrcLoc
loc String
s
    (String
arg, RealSrcLoc
after_arg_loc, String
after_arg_str) <- RealSrcLoc -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
after_spaces_loc String
after_spaces_str
    let (RealSrcLoc
after_arg_spaces_loc, String
after_arg_spaces_str)
          = RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces RealSrcLoc
after_arg_loc String
after_arg_str
    (forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
after_arg_loc String
arg forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      case String
after_arg_spaces_str of
        Char
',':String
after_comma -> RealSrcLoc -> String -> Either String [Located String]
readAsList (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
after_arg_spaces_loc Char
',') String
after_comma
        Char
']':String
after_bracket
          | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
after_bracket
          -> forall a b. b -> Either a b
Right []
        String
_ -> forall a b. a -> Either a b
Left (String
"Couldn't read " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Char
'[' forall a. a -> [a] -> [a]
: String
s) forall a. [a] -> [a] -> [a]
++ String
" as [String]")
             -- reinsert missing '[' for clarity.

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

-- | 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
  = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Located String]
flags) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall e. MsgEnvelope e -> Messages e
singleMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located String -> MsgEnvelope GhcMessage
mkMsg) [Located String]
flags
    where mkMsg :: Located String -> MsgEnvelope GhcMessage
mkMsg (L SrcSpan
loc String
flag)
              = forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc forall a b. (a -> b) -> a -> b
$
                PsMessage -> GhcMessage
GhcPsMessage forall a b. (a -> b) -> a -> b
$ PsHeaderMessage -> PsMessage
PsHeaderMessage forall a b. (a -> b) -> a -> b
$ String -> PsHeaderMessage
PsErrUnknownOptionsPragma String
flag

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

checkExtension :: ParserOpts -> Located FastString -> Located String
checkExtension :: ParserOpts -> Located FastString -> Located String
checkExtension ParserOpts
opts (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' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ParserOpts -> [String]
pSupportedExts ParserOpts
opts)
    then forall l e. l -> e -> GenLocated l e
L SrcSpan
l (String
"-X"forall a. [a] -> [a] -> [a]
++String
ext')
    else forall a. ParserOpts -> SrcSpan -> String -> a
unsupportedExtnError ParserOpts
opts SrcSpan
l String
ext'
  where
    ext' :: String
ext' = FastString -> String
unpackFS FastString
ext

languagePragParseError :: SrcSpan -> a
languagePragParseError :: forall a. SrcSpan -> a
languagePragParseError SrcSpan
loc =
    forall a. SrcSpan -> PsHeaderMessage -> a
throwErr SrcSpan
loc forall a b. (a -> b) -> a -> b
$ PsHeaderMessage
PsErrParseLanguagePragma

unsupportedExtnError :: ParserOpts -> SrcSpan -> String -> a
unsupportedExtnError :: forall a. ParserOpts -> SrcSpan -> String -> a
unsupportedExtnError ParserOpts
opts SrcSpan
loc String
unsup =
    forall a. SrcSpan -> PsHeaderMessage -> a
throwErr SrcSpan
loc forall a b. (a -> b) -> a -> b
$ String -> [String] -> PsHeaderMessage
PsErrUnsupportedExt String
unsup (ParserOpts -> [String]
pSupportedExts ParserOpts
opts)

optionsParseError :: String -> SrcSpan -> a     -- #15053
optionsParseError :: forall a. String -> SrcSpan -> a
optionsParseError String
str SrcSpan
loc =
  forall a. SrcSpan -> PsHeaderMessage -> a
throwErr SrcSpan
loc forall a b. (a -> b) -> a -> b
$ String -> PsHeaderMessage
PsErrParseOptionsPragma String
str

throwErr :: SrcSpan -> PsHeaderMessage -> a                -- #15053
throwErr :: forall a. SrcSpan -> PsHeaderMessage -> a
throwErr SrcSpan
loc PsHeaderMessage
ps_msg =
  let msg :: MsgEnvelope GhcMessage
msg = forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc forall a b. (a -> b) -> a -> b
$ PsMessage -> GhcMessage
GhcPsMessage (PsHeaderMessage -> PsMessage
PsHeaderMessage PsHeaderMessage
ps_msg)
  in forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> SourceError
mkSrcErr forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage MsgEnvelope GhcMessage
msg