{-# 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 P (Located (HsModule GhcPs))
-> PState -> ParseResult (Located (HsModule GhcPs))
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
      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. a -> IO a
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 GhcPs)
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 a b. (a -> b) -> IO a -> IO b
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 GhcPs
hsmod = Located (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc Located (HsModule GhcPs)
rdr_module
                mb_mod :: Maybe (XRec GhcPs ModuleName)
mb_mod = HsModule GhcPs -> Maybe (XRec GhcPs ModuleName)
forall p. HsModule p -> Maybe (XRec p ModuleName)
hsmodName HsModule GhcPs
hsmod
                imps :: [LImportDecl GhcPs]
imps = HsModule GhcPs -> [LImportDecl GhcPs]
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)
Maybe (GenLocated SrcSpanAnnA ModuleName)
mb_mod Maybe (GenLocated SrcSpanAnnA ModuleName)
-> GenLocated SrcSpanAnnA ModuleName
-> GenLocated SrcSpanAnnA ModuleName
forall a. Maybe a -> a -> a
`orElse` SrcSpanAnnA -> ModuleName -> GenLocated SrcSpanAnnA ModuleName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
main_loc) ModuleName
mAIN_NAME
                ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls) = (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
    [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (IsBootInterface -> Bool)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> IsBootInterface)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> IsBootInterface
forall pass. ImportDecl pass -> IsBootInterface
ideclSource (ImportDecl GhcPs -> IsBootInterface)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> IsBootInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc) [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl 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)
                  = (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
    [GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
gHC_PRIM) (ModuleName -> Bool)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ModuleName)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc
                                  (GenLocated SrcSpanAnnA ModuleName -> ModuleName)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs)
    -> GenLocated SrcSpanAnnA ModuleName)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> XRec GhcPs ModuleName
ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName (ImportDecl GhcPs -> GenLocated SrcSpanAnnA ModuleName)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> GenLocated SrcSpanAnnA ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc)
                                 [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls

                implicit_imports :: [LImportDecl GhcPs]
implicit_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports (GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA ModuleName
mod) SrcSpan
main_loc
                                                 Bool
implicit_prelude [LImportDecl GhcPs]
imps
                convImport :: GenLocated l (ImportDecl GhcPs)
-> (RawPkgQual, GenLocated b ModuleName)
convImport (L l
_ (ImportDecl GhcPs
i::ImportDecl GhcPs))
                  = (ImportDecl GhcPs -> ImportDeclPkgQual GhcPs
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
i, GenLocated SrcSpanAnnA ModuleName -> GenLocated b ModuleName
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc (GenLocated SrcSpanAnnA ModuleName -> GenLocated b ModuleName)
-> GenLocated SrcSpanAnnA ModuleName -> GenLocated b ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
i)
              in
              ([(RawPkgQual, Located ModuleName)],
 [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
     ([(RawPkgQual, Located ModuleName)],
      [(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((GenLocated SrcSpanAnnA (ImportDecl GhcPs)
 -> (RawPkgQual, Located ModuleName))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(RawPkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (RawPkgQual, Located ModuleName)
forall {b} {l}.
HasAnnotation b =>
GenLocated l (ImportDecl GhcPs)
-> (RawPkgQual, GenLocated b ModuleName)
convImport [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls
                     , (GenLocated SrcSpanAnnA (ImportDecl GhcPs)
 -> (RawPkgQual, Located ModuleName))
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [(RawPkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (RawPkgQual, Located ModuleName)
forall {b} {l}.
HasAnnotation b =>
GenLocated l (ImportDecl GhcPs)
-> (RawPkgQual, GenLocated b ModuleName)
convImport ([LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
implicit_imports [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps)
                     , Bool -> Bool
not ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ghc_prim_import)
                     , GenLocated SrcSpanAnnA ModuleName -> Located ModuleName
forall a e b.
(HasLoc (GenLocated a e), HasAnnotation b) =>
GenLocated a e -> GenLocated b e
reLoc GenLocated SrcSpanAnnA ModuleName
mod)

mkPrelImports :: ModuleName
              -> SrcSpan    -- Attribute the "import Prelude" to this location
              -> Bool -> [LImportDecl GhcPs]
              -> [LImportDecl GhcPs]
-- Construct the implicit declaration "import Prelude" (or not)
--
-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
-- because the former doesn't even look at Prelude.hi for instance
-- declarations, whereas the latter does.
mkPrelImports :: ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports ModuleName
this_mod SrcSpan
loc Bool
implicit_prelude [LImportDecl GhcPs]
import_decls
  | ModuleName
this_mod ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME
   Bool -> Bool -> Bool
|| Bool
explicit_prelude_import
   Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
implicit_prelude
  = []
  | Bool
otherwise = [LImportDecl GhcPs
preludeImportDecl]
  where
      explicit_prelude_import :: Bool
explicit_prelude_import = (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool
forall {l}. GenLocated l (ImportDecl GhcPs) -> Bool
is_prelude_import [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
import_decls

      is_prelude_import :: GenLocated l (ImportDecl GhcPs) -> Bool
is_prelude_import (L l
_ (ImportDecl GhcPs
decl::ImportDecl GhcPs)) =
        GenLocated SrcSpanAnnA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl GhcPs -> XRec GhcPs ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl GhcPs
decl) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME
        -- See #17045, package qualified imports are never counted as
        -- explicit prelude imports
        Bool -> Bool -> Bool
&& case ImportDecl GhcPs -> ImportDeclPkgQual GhcPs
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl GhcPs
decl of
            ImportDeclPkgQual GhcPs
RawPkgQual
NoRawPkgQual -> Bool
True
            RawPkgQual {} -> Bool
False


      loc' :: SrcSpanAnnA
loc' = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
      preludeImportDecl :: LImportDecl GhcPs
      preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
        = SrcSpanAnnA
-> ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ImportDecl { ideclExt :: XCImportDecl GhcPs
ideclExt       = XImportDeclPass
                                                    { ideclAnn :: EpAnn EpAnnImportDecl
ideclAnn = EpAnn EpAnnImportDecl
forall a. NoAnn a => a
noAnn
                                                    , ideclSourceText :: SourceText
ideclSourceText = SourceText
NoSourceText
                                                    , ideclImplicit :: Bool
ideclImplicit  = Bool
True   -- Implicit!
                                                    },
                                ideclName :: XRec GhcPs ModuleName
ideclName      = SrcSpanAnnA -> ModuleName -> GenLocated SrcSpanAnnA ModuleName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' ModuleName
pRELUDE_NAME,
                                ideclPkgQual :: ImportDeclPkgQual GhcPs
ideclPkgQual   = ImportDeclPkgQual GhcPs
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        = Maybe (XRec GhcPs ModuleName)
Maybe (GenLocated SrcSpanAnnA ModuleName)
forall a. Maybe a
Nothing,
                                ideclImportList :: Maybe (ImportListInterpretation, XRec GhcPs [LIE GhcPs])
ideclImportList = Maybe (ImportListInterpretation, 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 -> String -> IO (Messages PsMessage, [Located String])
getOptionsFromFile ParserOpts
opts String
filename
    = IO Handle
-> (Handle -> IO ())
-> (Handle -> IO (Messages PsMessage, [Located String]))
-> IO (Messages PsMessage, [Located String])
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
              (String -> IOMode -> IO Handle
openBinaryFile String
filename IOMode
ReadMode)
              (Handle -> IO ()
hClose)
              (\Handle
handle -> do
                  (warns, opts) <- ([Located Token] -> (Messages PsMessage, [Located String]))
-> IO [Located Token] -> IO (Messages PsMessage, [Located String])
forall a b. (a -> b) -> IO a -> IO b
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)
                  seqList opts
                    $ seqList (bagToList $ getMessages warns)
                    $ return (warns, 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
  buf <- Handle -> Int -> IO StringBuffer
hGetStringBufferBlock Handle
handle Int
blockSize
  let prag_state = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initPragState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc
  unsafeInterleaveIO $ lazyLexBuf handle prag_state False blockSize
 where
  loc :: RealSrcLoc
loc  = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1

  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state Bool
eof Int
size =
    case P (Located Token) -> PState -> ParseResult (Located Token)
forall a. P a -> PState -> ParseResult a
unP (Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False Located Token -> P (Located Token)
forall a. a -> P a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Located Token
t]
                  Token
_other -> do rest <- Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state' Bool
eof Int
size
                               return (t : 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 a. a -> IO a
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)
     nextbuf <- Handle -> Int -> IO StringBuffer
hGetStringBufferBlock Handle
handle Int
new_size
     if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
       newbuf <- appendStringBuffers (buffer state) nextbuf
       unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size


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

  lexAll :: PState -> [Located Token]
lexAll PState
state = case P (Located Token) -> PState -> ParseResult (Located Token)
forall a. P a -> PState -> ParseResult a
unP (Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False Located Token -> P (Located Token)
forall a. a -> P a
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 -> 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 <- 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 -> String -> Either String [Located String]
toArgs RealSrcLoc
starting_loc String
str of
                  Left String
_err -> String -> SrcSpan -> (Messages PsMessage, [Located String])
forall a. String -> SrcSpan -> a
optionsParseError String
str (SrcSpan -> (Messages PsMessage, [Located String]))
-> SrcSpan -> (Messages PsMessage, [Located String])
forall a b. (a -> b) -> a -> b
$   -- #15053
                                 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open) (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
close)
                  Right [Located String]
args -> ([Located String] -> [Located String])
-> (Messages PsMessage, [Located String])
-> (Messages PsMessage, [Located String])
forall a b.
(a -> b) -> (Messages PsMessage, a) -> (Messages PsMessage, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Located String]
args [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
++) ([Located Token] -> (Messages PsMessage, [Located String])
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 = String -> Maybe RealSrcSpan -> RealSrcSpan
forall a. HasDebugCallStack => 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 <- 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 String] -> [Located String])
-> (Messages PsMessage, [Located String])
-> (Messages PsMessage, [Located String])
forall a b.
(a -> b) -> (Messages PsMessage, a) -> (Messages PsMessage, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open)) [String
"-#include",String -> String
removeSpaces String
str] [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
++)
                     ([Located Token] -> (Messages PsMessage, [Located String])
parseToks [Located Token]
xs)
          parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
              | ITdocOptions String
str PsSpan
_ <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
open
              , Token
ITclose_prag       <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
close
              = ([Located String] -> [Located String])
-> (Messages PsMessage, [Located String])
-> (Messages PsMessage, [Located String])
forall a b.
(a -> b) -> (Messages PsMessage, a) -> (Messages PsMessage, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open)) [String
"-haddock-opts", String -> String
removeSpaces String
str] [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
++)
                     ([Located Token] -> (Messages PsMessage, [Located String])
parseToks [Located Token]
xs)
          parseToks (Located Token
open:[Located Token]
xs)
              | Token
ITlanguage_prag <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
open
              = [Located Token] -> (Messages PsMessage, [Located String])
parseLanguage [Located Token]
xs
          parseToks (Located Token
comment:[Located Token]
xs) -- Skip over comments
              | Token -> Bool
isComment (Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
comment)
              = [Located Token] -> (Messages PsMessage, [Located String])
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 String])
parseLanguage ((L SrcSpan
loc (ITconid FastString
fs)):[Located Token]
rest)
              = ([Located String] -> [Located String])
-> (Messages PsMessage, [Located String])
-> (Messages PsMessage, [Located String])
forall a b.
(a -> b) -> (Messages PsMessage, a) -> (Messages PsMessage, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParserOpts -> Located FastString -> Located String
checkExtension ParserOpts
opts (SrcSpan -> FastString -> Located FastString
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc FastString
fs) Located String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
:) ((Messages PsMessage, [Located String])
 -> (Messages PsMessage, [Located String]))
-> (Messages PsMessage, [Located String])
-> (Messages PsMessage, [Located String])
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]
_ -> SrcSpan -> (Messages PsMessage, [Located String])
forall a. SrcSpan -> a
languagePragParseError SrcSpan
loc
                  [] -> String -> (Messages PsMessage, [Located String])
forall a. HasCallStack => String -> a
panic String
"getOptions'.parseLanguage(1) went past eof token"
          parseLanguage (Located Token
tok:[Located Token]
_)
              = SrcSpan -> (Messages PsMessage, [Located String])
forall a. SrcSpan -> a
languagePragParseError (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
tok)
          parseLanguage []
              = String -> (Messages PsMessage, [Located String])
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
            = 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 String
_ <- 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 String
_ 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 -> 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 | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
rest -> [Located String] -> Either String [Located String]
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
cChar -> String -> String
forall 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 [] = (String -> String
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       = (String -> String
forall a. [a] -> [a]
reverse String
reversed_acc, RealSrcLoc
loc, Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs)
        | Bool
otherwise = String -> RealSrcLoc -> String -> (String, RealSrcLoc, String)
go (Char
cChar -> String -> String
forall 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 = (RealSrcLoc -> Char -> RealSrcLoc)
-> RealSrcLoc -> String -> RealSrcLoc
forall b a. (b -> a -> b) -> b -> [a] -> b
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 = SrcSpan -> a -> GenLocated SrcSpan 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 -> 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
      [] -> [Located String] -> Either String [Located String]
forall a b. b -> Either a b
Right []
      Char
'"' : String
_ -> do
        -- readAsString removes outer quotes
        (arg, new_loc, rest) <- RealSrcLoc -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
after_spaces_loc String
after_spaces_str
        check_for_space rest
        (locate after_spaces_loc new_loc arg:)
          `fmap` toArgs' new_loc rest
      String
_ -> case (Char -> Bool)
-> RealSrcLoc -> String -> (String, RealSrcLoc, String)
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 String
after_spaces_str of
            (String
argPart1, RealSrcLoc
loc2, s'' :: String
s''@(Char
'"':String
_)) -> do
                (argPart2, loc3, rest) <- RealSrcLoc -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
loc2 String
s''
                check_for_space rest
                -- show argPart2 to keep inner quotes
                (locate after_spaces_loc loc3 (argPart1 ++ show argPart2):)
                  `fmap` toArgs' loc3 rest
            (String
arg, RealSrcLoc
loc2, String
s'') -> (RealSrcLoc -> RealSrcLoc -> String -> Located String
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
loc2 String
argLocated String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
:)
                                  ([Located String] -> [Located String])
-> Either String [Located String] -> Either String [Located String]
forall a b. (a -> b) -> Either String a -> Either String b
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 [] = () -> Either String ()
forall a b. b -> Either a b
Right ()
  check_for_space (Char
c:String
_)
    | Char -> Bool
isSpace Char
c = () -> Either String ()
forall a b. b -> Either a b
Right ()
    | Bool
otherwise = String -> Either String ()
forall a b. a -> Either a b
Left (String
"Whitespace expected after string in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
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 = ReadP (String, a) -> ReadS (String, a)
forall a. ReadP a -> ReadS a
readP_to_S (ReadP a -> ReadP (String, a)
forall a. ReadP a -> ReadP (String, 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 -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
loc String
s = case String -> [((String, String), String)]
forall a. Read a => String -> [((String, a), String)]
reads_with_consumed String
s of
                [((String
consumed, String
arg), String
rest)] ->
                    (String, RealSrcLoc, String)
-> Either String (String, RealSrcLoc, String)
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)]
_ ->
                    String -> Either String (String, RealSrcLoc, String)
forall a b. a -> Either a b
Left (String
"Couldn't read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
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
    (arg, after_arg_loc, after_arg_str) <- RealSrcLoc -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
after_spaces_loc String
after_spaces_str
    let (after_arg_spaces_loc, after_arg_spaces_str)
          = consume_spaces after_arg_loc after_arg_str
    (locate after_spaces_loc after_arg_loc arg :) <$>
      case 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
          | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
after_bracket
          -> [Located String] -> Either String [Located String]
forall a b. b -> Either a b
Right []
        String
_ -> String -> Either String [Located String]
forall a b. a -> Either a b
Left (String
"Couldn't read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Char
'[' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s) String -> String -> String
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
  = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Located String] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Located String]
flags) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      IO () -> m ()
forall a. IO a -> m a
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 String -> Messages GhcMessage)
-> [Located String] -> Messages GhcMessage
forall m a. Monoid m => (a -> m) -> [a] -> m
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 String -> MsgEnvelope GhcMessage)
-> Located String
-> Messages GhcMessage
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)
              = 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
$ 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' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ParserOpts -> [String]
pSupportedExts ParserOpts
opts)
    then SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (String
"-X"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
ext')
    else ParserOpts -> SrcSpan -> String -> Located String
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 =
    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 :: forall a. ParserOpts -> SrcSpan -> String -> a
unsupportedExtnError ParserOpts
opts SrcSpan
loc String
unsup =
    SrcSpan -> PsHeaderMessage -> a
forall a. SrcSpan -> PsHeaderMessage -> a
throwErr SrcSpan
loc (PsHeaderMessage -> a) -> PsHeaderMessage -> a
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 =
  SrcSpan -> PsHeaderMessage -> a
forall a. SrcSpan -> PsHeaderMessage -> a
throwErr SrcSpan
loc (PsHeaderMessage -> a) -> PsHeaderMessage -> a
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 = 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. (HasCallStack, 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