{-# 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
-> FilePath
-> FilePath
-> IO
     (Either
        (Messages PsMessage)
        ([(RawPkgQual, Located ModuleName)],
         [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
getImports ParserOpts
popts Bool
implicit_prelude StringBuffer
buf FilePath
filename FilePath
source_filename = do
  let loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
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
  (Messages PsMessage)
  ([(RawPkgQual, Located ModuleName)],
   [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
     (Either
        (Messages PsMessage)
        ([(RawPkgQual, Located ModuleName)],
         [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (Messages PsMessage)
   ([(RawPkgQual, Located ModuleName)],
    [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
 -> IO
      (Either
         (Messages PsMessage)
         ([(RawPkgQual, Located ModuleName)],
          [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)))
-> Either
     (Messages PsMessage)
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
     (Either
        (Messages PsMessage)
        ([(RawPkgQual, Located ModuleName)],
         [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
forall a b. (a -> b) -> a -> b
$ Messages PsMessage
-> Either
     (Messages PsMessage)
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall a b. a -> Either a b
Left (Messages PsMessage
 -> Either
      (Messages PsMessage)
      ([(RawPkgQual, Located ModuleName)],
       [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
-> Messages PsMessage
-> Either
     (Messages PsMessage)
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall a b. (a -> b) -> a -> b
$ PState -> Messages PsMessage
getPsErrorMessages PState
pst
    POk PState
pst Located HsModule
rdr_module -> (([(RawPkgQual, Located ModuleName)],
  [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
 -> Either
      (Messages PsMessage)
      ([(RawPkgQual, Located ModuleName)],
       [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
-> IO
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
     (Either
        (Messages PsMessage)
        ([(RawPkgQual, Located ModuleName)],
         [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(RawPkgQual, Located ModuleName)],
 [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> Either
     (Messages PsMessage)
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall a b. b -> Either a b
Right (IO
   ([(RawPkgQual, Located ModuleName)],
    [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
 -> IO
      (Either
         (Messages PsMessage)
         ([(RawPkgQual, Located ModuleName)],
          [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)))
-> IO
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
     (Either
        (Messages PsMessage)
        ([(RawPkgQual, Located ModuleName)],
         [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
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 (Messages PsMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages PsMessage
errs)
        then Messages GhcMessage
-> IO
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsMessage
errs)
        else
          let   hsmod :: HsModule
hsmod = Located HsModule -> HsModule
forall l e. GenLocated l e -> e
unLoc Located HsModule
rdr_module
                mb_mod :: Maybe (LocatedA ModuleName)
mb_mod = HsModule -> Maybe (LocatedA 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 (FilePath -> FastString
mkFastString FilePath
source_filename)
                                       Int
1 Int
1)
                mod :: LocatedA ModuleName
mod = Maybe (LocatedA ModuleName)
mb_mod Maybe (LocatedA ModuleName)
-> LocatedA ModuleName -> LocatedA ModuleName
forall a. Maybe a -> a -> a
`orElse` SrcAnn AnnListItem -> ModuleName -> LocatedA ModuleName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn AnnListItem
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
main_loc) ModuleName
mAIN_NAME
                ([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
src_idecls, [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
ord_idecls) = (GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs) -> Bool)
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> ([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)],
    [GenLocated (SrcAnn AnnListItem) (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 (SrcAnn AnnListItem) (ImportDecl GhcPs)
    -> IsBootInterface)
-> GenLocated (SrcAnn AnnListItem) (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 (SrcAnn AnnListItem) (ImportDecl GhcPs)
    -> ImportDecl GhcPs)
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> IsBootInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc) [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
[LImportDecl GhcPs]
imps

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

                implicit_imports :: [LImportDecl GhcPs]
implicit_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports (LocatedA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc LocatedA 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) = (ImportDecl pass -> ImportDeclPkgQual pass
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl pass
i, LocatedAn a ModuleName -> Located ModuleName
forall a e. LocatedAn a e -> Located e
reLoc (LocatedAn a ModuleName -> Located ModuleName)
-> LocatedAn a ModuleName -> Located ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl pass -> XRec pass ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
i)
              in
              ([(RawPkgQual, Located ModuleName)],
 [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall (m :: * -> *) a. Monad m => a -> m a
return ((GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
 -> (RawPkgQual, Located ModuleName))
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> [(RawPkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> (RawPkgQual, Located ModuleName)
forall pass a l.
(XRec pass ModuleName ~ LocatedAn a ModuleName) =>
GenLocated l (ImportDecl pass)
-> (ImportDeclPkgQual pass, Located ModuleName)
convImport [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
src_idecls
                     , (GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
 -> (RawPkgQual, Located ModuleName))
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> [(RawPkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> (RawPkgQual, Located ModuleName)
forall pass a l.
(XRec pass ModuleName ~ LocatedAn a ModuleName) =>
GenLocated l (ImportDecl pass)
-> (ImportDeclPkgQual pass, Located ModuleName)
convImport ([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
[LImportDecl GhcPs]
implicit_imports [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
ordinary_imps)
                     , Bool -> Bool
not ([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
ghc_prim_import)
                     , LocatedA ModuleName -> Located ModuleName
forall a e. LocatedAn a e -> Located e
reLoc LocatedA 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 (SrcAnn AnnListItem) (ImportDecl GhcPs) -> Bool)
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs) -> Bool
forall pass l l.
(ImportDeclPkgQual pass ~ RawPkgQual,
 XRec pass ModuleName ~ GenLocated l ModuleName) =>
GenLocated l (ImportDecl pass) -> Bool
is_prelude_import [GenLocated (SrcAnn AnnListItem) (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 -> ImportDeclPkgQual pass
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl pass
decl of
            ImportDeclPkgQual pass
NoRawPkgQual -> Bool
True
            RawPkgQual b -> StringLiteral -> FastString
sl_fs StringLiteral
b FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId -> FastString
unitIdFS UnitId
baseUnitId


      loc' :: SrcAnn AnnListItem
loc' = SrcSpan -> SrcAnn AnnListItem
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
      preludeImportDecl :: LImportDecl GhcPs
      preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
        = SrcAnn AnnListItem
-> ImportDecl GhcPs
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcAnn AnnListItem
loc' (ImportDecl GhcPs
 -> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs))
-> ImportDecl GhcPs
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ImportDecl :: forall pass.
XCImportDecl pass
-> SourceText
-> XRec pass ModuleName
-> ImportDeclPkgQual pass
-> IsBootInterface
-> Bool
-> ImportDeclQualifiedStyle
-> Bool
-> Maybe (XRec pass ModuleName)
-> Maybe (Bool, XRec pass [LIE pass])
-> ImportDecl pass
ImportDecl { ideclExt :: XCImportDecl GhcPs
ideclExt       = XCImportDecl GhcPs
forall a. EpAnn a
noAnn,
                                ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText,
                                ideclName :: XRec GhcPs ModuleName
ideclName      = SrcAnn AnnListItem -> ModuleName -> LocatedA ModuleName
forall l e. l -> e -> GenLocated l e
L SrcAnn AnnListItem
loc' ModuleName
pRELUDE_NAME,
                                ideclPkgQual :: ImportDeclPkgQual GhcPs
ideclPkgQual   = RawPkgQual
ImportDeclPkgQual GhcPs
NoRawPkgQual,
                                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 :: ParserOpts
                   -> FilePath            -- ^ Input file
                   -> IO (Messages PsMessage, [Located String]) -- ^ Parsed options, if any.
getOptionsFromFile :: ParserOpts
-> FilePath -> IO (Messages PsMessage, [Located FilePath])
getOptionsFromFile ParserOpts
opts FilePath
filename
    = IO Handle
-> (Handle -> IO ())
-> (Handle -> IO (Messages PsMessage, [Located FilePath]))
-> IO (Messages PsMessage, [Located FilePath])
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
              (FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
filename IOMode
ReadMode)
              (Handle -> IO ()
hClose)
              (\Handle
handle -> do
                  (Messages PsMessage
warns, [Located FilePath]
opts) <- ([Located Token] -> (Messages PsMessage, [Located FilePath]))
-> IO [Located Token]
-> IO (Messages PsMessage, [Located FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParserOpts
-> [Located Token] -> (Messages PsMessage, [Located FilePath])
getOptions' ParserOpts
opts)
                               (ParserOpts -> FilePath -> Handle -> IO [Located Token]
lazyGetToks ParserOpts
opts' FilePath
filename Handle
handle)
                  [Located FilePath]
-> IO (Messages PsMessage, [Located FilePath])
-> IO (Messages PsMessage, [Located FilePath])
forall a b. [a] -> b -> b
seqList [Located FilePath]
opts
                    (IO (Messages PsMessage, [Located FilePath])
 -> IO (Messages PsMessage, [Located FilePath]))
-> IO (Messages PsMessage, [Located FilePath])
-> IO (Messages PsMessage, [Located FilePath])
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope PsMessage]
-> IO (Messages PsMessage, [Located FilePath])
-> IO (Messages PsMessage, [Located FilePath])
forall a b. [a] -> b -> b
seqList (Bag (MsgEnvelope PsMessage) -> [MsgEnvelope PsMessage]
forall a. Bag a -> [a]
bagToList (Bag (MsgEnvelope PsMessage) -> [MsgEnvelope PsMessage])
-> Bag (MsgEnvelope PsMessage) -> [MsgEnvelope PsMessage]
forall a b. (a -> b) -> a -> b
$ Messages PsMessage -> Bag (MsgEnvelope PsMessage)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages PsMessage
warns)
                    (IO (Messages PsMessage, [Located FilePath])
 -> IO (Messages PsMessage, [Located FilePath]))
-> IO (Messages PsMessage, [Located FilePath])
-> IO (Messages PsMessage, [Located FilePath])
forall a b. (a -> b) -> a -> b
$ (Messages PsMessage, [Located FilePath])
-> IO (Messages PsMessage, [Located FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages PsMessage
warns, [Located FilePath]
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 -> FilePath -> Handle -> IO [Located Token]
lazyGetToks ParserOpts
popts FilePath
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 (FilePath -> FastString
mkFastString FilePath
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 -> FilePath -> StringBuffer -> [Located Token]
getToks ParserOpts
popts FilePath
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 (FilePath -> FastString
mkFastString FilePath
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 :: ParserOpts
           -> StringBuffer -- ^ Input Buffer
           -> FilePath     -- ^ Source filename.  Used for location info.
           -> (Messages PsMessage,[Located String]) -- ^ warnings and parsed options.
getOptions :: ParserOpts
-> StringBuffer
-> FilePath
-> (Messages PsMessage, [Located FilePath])
getOptions ParserOpts
opts StringBuffer
buf FilePath
filename
    = ParserOpts
-> [Located Token] -> (Messages PsMessage, [Located FilePath])
getOptions' ParserOpts
opts (ParserOpts -> FilePath -> StringBuffer -> [Located Token]
getToks ParserOpts
opts FilePath
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 FilePath])
getOptions' ParserOpts
opts [Located Token]
toks
    = [Located Token] -> (Messages PsMessage, [Located FilePath])
parseToks [Located Token]
toks
    where
          parseToks :: [Located Token] -> (Messages PsMessage, [Located FilePath])
parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
              | IToptions_prag FilePath
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 RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs RealSrcLoc
starting_loc FilePath
str of
                  Left FilePath
_err -> FilePath -> SrcSpan -> (Messages PsMessage, [Located FilePath])
forall a. FilePath -> SrcSpan -> a
optionsParseError FilePath
str (SrcSpan -> (Messages PsMessage, [Located FilePath]))
-> SrcSpan -> (Messages PsMessage, [Located FilePath])
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 [Located FilePath]
args -> ([Located FilePath] -> [Located FilePath])
-> (Messages PsMessage, [Located FilePath])
-> (Messages PsMessage, [Located FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Located FilePath]
args [Located FilePath] -> [Located FilePath] -> [Located FilePath]
forall a. [a] -> [a] -> [a]
++) ([Located Token] -> (Messages PsMessage, [Located FilePath])
parseToks [Located Token]
xs)
            where
              src_span :: SrcSpan
src_span      = Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open
              real_src_span :: RealSrcSpan
real_src_span = FilePath -> Maybe RealSrcSpan -> RealSrcSpan
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"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 FilePath
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
              = ([Located FilePath] -> [Located FilePath])
-> (Messages PsMessage, [Located FilePath])
-> (Messages PsMessage, [Located FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Located FilePath) -> [FilePath] -> [Located FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> FilePath -> Located FilePath
forall l e. l -> e -> GenLocated l e
L (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open)) [FilePath
"-#include",FilePath -> FilePath
removeSpaces FilePath
str] [Located FilePath] -> [Located FilePath] -> [Located FilePath]
forall a. [a] -> [a] -> [a]
++)
                     ([Located Token] -> (Messages PsMessage, [Located FilePath])
parseToks [Located Token]
xs)
          parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
              | ITdocOptions FilePath
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
              = ([Located FilePath] -> [Located FilePath])
-> (Messages PsMessage, [Located FilePath])
-> (Messages PsMessage, [Located FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Located FilePath) -> [FilePath] -> [Located FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> FilePath -> Located FilePath
forall l e. l -> e -> GenLocated l e
L (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open)) [FilePath
"-haddock-opts", FilePath -> FilePath
removeSpaces FilePath
str] [Located FilePath] -> [Located FilePath] -> [Located FilePath]
forall a. [a] -> [a] -> [a]
++)
                     ([Located Token] -> (Messages PsMessage, [Located FilePath])
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] -> (Messages PsMessage, [Located FilePath])
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] -> (Messages PsMessage, [Located FilePath])
parseToks [Located Token]
xs
          -- At the end of the header, warn about all the misplaced pragmas
          parseToks [Located Token]
xs = ([Messages PsMessage] -> Messages PsMessage
forall (f :: * -> *) e. Foldable f => f (Messages e) -> Messages e
unionManyMessages ([Messages PsMessage] -> Messages PsMessage)
-> [Messages PsMessage] -> Messages PsMessage
forall a b. (a -> b) -> a -> b
$ (Located Token -> Maybe (Messages PsMessage))
-> [Located Token] -> [Messages PsMessage]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Located Token -> Maybe (Messages PsMessage)
mkMessage [Located Token]
xs ,[])

          parseLanguage :: [Located Token] -> (Messages PsMessage, [Located FilePath])
parseLanguage ((L SrcSpan
loc (ITconid FastString
fs)):[Located Token]
rest)
              = ([Located FilePath] -> [Located FilePath])
-> (Messages PsMessage, [Located FilePath])
-> (Messages PsMessage, [Located FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParserOpts -> Located FastString -> Located FilePath
checkExtension ParserOpts
opts (SrcSpan -> FastString -> Located FastString
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc FastString
fs) Located FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:) ((Messages PsMessage, [Located FilePath])
 -> (Messages PsMessage, [Located FilePath]))
-> (Messages PsMessage, [Located FilePath])
-> (Messages PsMessage, [Located FilePath])
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 FilePath])
parseLanguage [Located Token]
more
                  (L SrcSpan
_loc Token
ITclose_prag):[Located Token]
more -> [Located Token] -> (Messages PsMessage, [Located FilePath])
parseToks [Located Token]
more
                  (L SrcSpan
loc Token
_):[Located Token]
_ -> SrcSpan -> (Messages PsMessage, [Located FilePath])
forall a. SrcSpan -> a
languagePragParseError SrcSpan
loc
                  [] -> FilePath -> (Messages PsMessage, [Located FilePath])
forall a. FilePath -> a
panic FilePath
"getOptions'.parseLanguage(1) went past eof token"
          parseLanguage (Located Token
tok:[Located Token]
_)
              = SrcSpan -> (Messages PsMessage, [Located FilePath])
forall a. SrcSpan -> a
languagePragParseError (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
tok)
          parseLanguage []
              = FilePath -> (Messages PsMessage, [Located FilePath])
forall a. FilePath -> a
panic FilePath
"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 FilePath
_ <- Token
token
            = Messages PsMessage -> Maybe (Messages PsMessage)
forall a. a -> Maybe a
Just (MsgEnvelope PsMessage -> Messages PsMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope PsMessage -> Messages PsMessage)
-> MsgEnvelope PsMessage -> Messages PsMessage
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
loc (FileHeaderPragmaType -> PsMessage
PsWarnMisplacedPragma FileHeaderPragmaType
OptionsPrag))
            | ITinclude_prag FilePath
_ <- Token
token
            = Messages PsMessage -> Maybe (Messages PsMessage)
forall a. a -> Maybe a
Just (MsgEnvelope PsMessage -> Messages PsMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope PsMessage -> Messages PsMessage)
-> MsgEnvelope PsMessage -> Messages PsMessage
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
loc (FileHeaderPragmaType -> PsMessage
PsWarnMisplacedPragma FileHeaderPragmaType
IncludePrag))
            | ITdocOptions FilePath
_ PsSpan
_ <- Token
token
            = Messages PsMessage -> Maybe (Messages PsMessage)
forall a. a -> Maybe a
Just (MsgEnvelope PsMessage -> Messages PsMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope PsMessage -> Messages PsMessage)
-> MsgEnvelope PsMessage -> Messages PsMessage
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> PsMessage -> MsgEnvelope PsMessage
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
            = Messages PsMessage -> Maybe (Messages PsMessage)
forall a. a -> Maybe a
Just (MsgEnvelope PsMessage -> Messages PsMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope PsMessage -> Messages PsMessage)
-> MsgEnvelope PsMessage -> Messages PsMessage
forall a b. (a -> b) -> a -> b
$ DiagOpts -> SrcSpan -> PsMessage -> MsgEnvelope PsMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
loc (FileHeaderPragmaType -> PsMessage
PsWarnMisplacedPragma FileHeaderPragmaType
LanguagePrag))
            | Bool
otherwise = Maybe (Messages PsMessage)
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 -> FilePath -> Either FilePath [Located FilePath]
toArgs RealSrcLoc
starting_loc FilePath
orig_str
    = let (RealSrcLoc
after_spaces_loc, FilePath
after_spaces_str) = RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
starting_loc FilePath
orig_str in
      case FilePath
after_spaces_str of
      Char
'[':FilePath
after_bracket ->
        let after_bracket_loc :: RealSrcLoc
after_bracket_loc = RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
after_spaces_loc Char
'['
            (RealSrcLoc
after_bracket_spaces_loc, FilePath
after_bracket_spaces_str)
              = RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
after_bracket_loc FilePath
after_bracket in
        case FilePath
after_bracket_spaces_str of
          Char
']':FilePath
rest | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace FilePath
rest -> [Located FilePath] -> Either FilePath [Located FilePath]
forall a b. b -> Either a b
Right []
          FilePath
_ -> RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
readAsList RealSrcLoc
after_bracket_spaces_loc FilePath
after_bracket_spaces_str

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

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

  advance_src_loc_many :: RealSrcLoc -> String -> RealSrcLoc
  advance_src_loc_many :: RealSrcLoc -> FilePath -> RealSrcLoc
advance_src_loc_many = (RealSrcLoc -> Char -> RealSrcLoc)
-> RealSrcLoc -> FilePath -> RealSrcLoc
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 :: RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
begin RealSrcLoc
end a
x = SrcSpan -> a -> Located a
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
begin RealSrcLoc
end) Maybe BufSpan
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 -> FilePath -> Either FilePath [Located FilePath]
toArgs' RealSrcLoc
loc FilePath
s =
    let (RealSrcLoc
after_spaces_loc, FilePath
after_spaces_str) = RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
loc FilePath
s in
    case FilePath
after_spaces_str of
      [] -> [Located FilePath] -> Either FilePath [Located FilePath]
forall a b. b -> Either a b
Right []
      Char
'"' : FilePath
_ -> do
        -- readAsString removes outer quotes
        (FilePath
arg, RealSrcLoc
new_loc, FilePath
rest) <- RealSrcLoc
-> FilePath -> Either FilePath (FilePath, RealSrcLoc, FilePath)
readAsString RealSrcLoc
after_spaces_loc FilePath
after_spaces_str
        FilePath -> Either FilePath ()
check_for_space FilePath
rest
        (RealSrcLoc -> RealSrcLoc -> FilePath -> Located FilePath
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
new_loc FilePath
argLocated FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:)
          ([Located FilePath] -> [Located FilePath])
-> Either FilePath [Located FilePath]
-> Either FilePath [Located FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs' RealSrcLoc
new_loc FilePath
rest
      FilePath
_ -> case (Char -> Bool)
-> RealSrcLoc -> FilePath -> (FilePath, RealSrcLoc, FilePath)
break_with_loc (Char -> Bool
isSpace (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"')) RealSrcLoc
after_spaces_loc FilePath
after_spaces_str of
            (FilePath
argPart1, RealSrcLoc
loc2, s'' :: FilePath
s''@(Char
'"':FilePath
_)) -> do
                (FilePath
argPart2, RealSrcLoc
loc3, FilePath
rest) <- RealSrcLoc
-> FilePath -> Either FilePath (FilePath, RealSrcLoc, FilePath)
readAsString RealSrcLoc
loc2 FilePath
s''
                FilePath -> Either FilePath ()
check_for_space FilePath
rest
                -- show argPart2 to keep inner quotes
                (RealSrcLoc -> RealSrcLoc -> FilePath -> Located FilePath
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
loc3 (FilePath
argPart1 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
argPart2)Located FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:)
                  ([Located FilePath] -> [Located FilePath])
-> Either FilePath [Located FilePath]
-> Either FilePath [Located FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs' RealSrcLoc
loc3 FilePath
rest
            (FilePath
arg, RealSrcLoc
loc2, FilePath
s'') -> (RealSrcLoc -> RealSrcLoc -> FilePath -> Located FilePath
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
loc2 FilePath
argLocated FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:)
                                  ([Located FilePath] -> [Located FilePath])
-> Either FilePath [Located FilePath]
-> Either FilePath [Located FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs' RealSrcLoc
loc2 FilePath
s''

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

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

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

   -- input has had the '[' stripped off
  readAsList :: RealSrcLoc -> String -> Either String [Located String]
  readAsList :: RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
readAsList RealSrcLoc
loc FilePath
s = do
    let (RealSrcLoc
after_spaces_loc, FilePath
after_spaces_str) = RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
loc FilePath
s
    (FilePath
arg, RealSrcLoc
after_arg_loc, FilePath
after_arg_str) <- RealSrcLoc
-> FilePath -> Either FilePath (FilePath, RealSrcLoc, FilePath)
readAsString RealSrcLoc
after_spaces_loc FilePath
after_spaces_str
    let (RealSrcLoc
after_arg_spaces_loc, FilePath
after_arg_spaces_str)
          = RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
after_arg_loc FilePath
after_arg_str
    (RealSrcLoc -> RealSrcLoc -> FilePath -> Located FilePath
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
after_arg_loc FilePath
arg Located FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:) ([Located FilePath] -> [Located FilePath])
-> Either FilePath [Located FilePath]
-> Either FilePath [Located FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      case FilePath
after_arg_spaces_str of
        Char
',':FilePath
after_comma -> RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
readAsList (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
after_arg_spaces_loc Char
',') FilePath
after_comma
        Char
']':FilePath
after_bracket
          | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace FilePath
after_bracket
          -> [Located FilePath] -> Either FilePath [Located FilePath]
forall a b. b -> Either a b
Right []
        FilePath
_ -> FilePath -> Either FilePath [Located FilePath]
forall a b. a -> Either a b
Left (FilePath
"Couldn't read " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show (Char
'[' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
s) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" 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 :: [Located FilePath] -> m ()
checkProcessArgsResult [Located FilePath]
flags
  = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Located FilePath] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Located FilePath]
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
$ Messages GhcMessage -> IO ()
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (Messages GhcMessage -> IO ()) -> Messages GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ (Located FilePath -> Messages GhcMessage)
-> [Located FilePath] -> Messages GhcMessage
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> (Located FilePath -> MsgEnvelope GhcMessage)
-> Located FilePath
-> Messages GhcMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located FilePath -> MsgEnvelope GhcMessage
mkMsg) [Located FilePath]
flags
    where mkMsg :: Located FilePath -> MsgEnvelope GhcMessage
mkMsg (L SrcSpan
loc FilePath
flag)
              = SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
                PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage) -> PsMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ PsHeaderMessage -> PsMessage
PsHeaderMessage (PsHeaderMessage -> PsMessage) -> PsHeaderMessage -> PsMessage
forall a b. (a -> b) -> a -> b
$ FilePath -> PsHeaderMessage
PsErrUnknownOptionsPragma FilePath
flag

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

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

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

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

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

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