{-# LANGUAGE TypeFamilies #-}
module GHC.Parser.Header
( getImports
, mkPrelImports
, getOptionsFromFile
, getOptions
, toArgs
, checkProcessArgsResult
)
where
import GHC.Prelude
import GHC.Data.Bag
import GHC.Driver.Errors.Types
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)
getImports :: ParserOpts
-> Bool
-> StringBuffer
-> FilePath
-> FilePath
-> IO (Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)],
Bool,
Located ModuleName))
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 ->
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
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 ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
main_loc) ModuleName
mAIN_NAME
([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls) = (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (ImportDecl GhcPs)],
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (IsBootInterface -> Bool)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> IsBootInterface)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> IsBootInterface
forall pass. ImportDecl pass -> IsBootInterface
ideclSource (ImportDecl GhcPs -> IsBootInterface)
-> (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs)
-> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> IsBootInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc) [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
imps
([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 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, GenLocated (SrcAnn a) ModuleName -> Located ModuleName
forall a e. LocatedAn a e -> Located e
reLoc (GenLocated (SrcAnn a) ModuleName -> Located ModuleName)
-> GenLocated (SrcAnn 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 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)
-> (ImportDeclPkgQual GhcPs, Located ModuleName)
GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (RawPkgQual, Located ModuleName)
forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (ImportDeclPkgQual pass, Located ModuleName)
convImport [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls
, (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)
-> (ImportDeclPkgQual GhcPs, Located ModuleName)
GenLocated SrcSpanAnnA (ImportDecl GhcPs)
-> (RawPkgQual, Located ModuleName)
forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (ImportDeclPkgQual pass, Located 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. LocatedAn a e -> Located e
reLoc GenLocated SrcSpanAnnA ModuleName
mod)
mkPrelImports :: ModuleName
-> SrcSpan
-> Bool -> [LImportDecl GhcPs]
-> [LImportDecl GhcPs]
mkPrelImports :: ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports ModuleName
this_mod SrcSpan
loc Bool
implicit_prelude [LImportDecl GhcPs]
import_decls
| ModuleName
this_mod ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME
Bool -> Bool -> Bool
|| Bool
explicit_prelude_import
Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
implicit_prelude
= []
| Bool
otherwise = [LImportDecl GhcPs
preludeImportDecl]
where
explicit_prelude_import :: Bool
explicit_prelude_import = (GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool)
-> [GenLocated SrcSpanAnnA (ImportDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated SrcSpanAnnA (ImportDecl GhcPs) -> Bool
forall {pass} {l} {l}.
(XRec pass ModuleName ~ GenLocated l ModuleName,
ImportDeclPkgQual pass ~ RawPkgQual) =>
GenLocated l (ImportDecl pass) -> Bool
is_prelude_import [LImportDecl GhcPs]
[GenLocated SrcSpanAnnA (ImportDecl 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
Bool -> Bool -> Bool
&& case ImportDecl pass -> ImportDeclPkgQual pass
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl pass
decl of
ImportDeclPkgQual pass
RawPkgQual
NoRawPkgQual -> Bool
True
RawPkgQual StringLiteral
b -> StringLiteral -> FastString
sl_fs StringLiteral
b FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId -> FastString
unitIdFS UnitId
baseUnitId
loc' :: SrcSpanAnnA
loc' = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
= SrcSpanAnnA
-> ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs))
-> ImportDecl GhcPs -> GenLocated SrcSpanAnnA (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ImportDecl { ideclExt :: XCImportDecl GhcPs
ideclExt = XImportDeclPass
{ ideclAnn :: EpAnn EpAnnImportDecl
ideclAnn = EpAnn EpAnnImportDecl
forall a. EpAnn a
noAnn
, ideclSourceText :: SourceText
ideclSourceText = SourceText
NoSourceText
, ideclImplicit :: Bool
ideclImplicit = Bool
True
},
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,
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])
Maybe
(ImportListInterpretation,
GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
forall a. Maybe a
Nothing }
getOptionsFromFile :: ParserOpts
-> FilePath
-> IO (Messages PsMessage, [Located String])
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
(Messages PsMessage
warns, [Located String]
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)
[Located String]
-> IO (Messages PsMessage, [Located String])
-> IO (Messages PsMessage, [Located String])
forall a b. [a] -> b -> b
seqList [Located String]
opts
(IO (Messages PsMessage, [Located String])
-> IO (Messages PsMessage, [Located String]))
-> IO (Messages PsMessage, [Located String])
-> IO (Messages PsMessage, [Located String])
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope PsMessage]
-> IO (Messages PsMessage, [Located String])
-> IO (Messages PsMessage, [Located String])
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 String])
-> IO (Messages PsMessage, [Located String]))
-> IO (Messages PsMessage, [Located String])
-> IO (Messages PsMessage, [Located String])
forall a b. (a -> b) -> a -> b
$ (Messages PsMessage, [Located String])
-> IO (Messages PsMessage, [Located String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages PsMessage
warns, [Located String]
opts))
where
opts' :: ParserOpts
opts' = ParserOpts -> ParserOpts
disableHaddock ParserOpts
opts
blockSize :: Int
blockSize :: Int
blockSize = Int
1024
lazyGetToks :: ParserOpts -> FilePath -> Handle -> IO [Located Token]
lazyGetToks :: ParserOpts -> String -> Handle -> IO [Located Token]
lazyGetToks ParserOpts
popts String
filename Handle
handle = do
StringBuffer
buf <- Handle -> Int -> IO StringBuffer
hGetStringBufferBlock Handle
handle Int
blockSize
let prag_state :: PState
prag_state = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initPragState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc
IO [Located Token] -> IO [Located Token]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [Located Token] -> IO [Located Token])
-> IO [Located Token] -> IO [Located Token]
forall a b. (a -> b) -> a -> b
$ Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
prag_state Bool
False Int
blockSize
where
loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1
lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state Bool
eof Int
size =
case P (Located Token) -> PState -> ParseResult (Located Token)
forall a. P a -> PState -> ParseResult a
unP (Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False Located Token -> P (Located Token)
forall a. a -> P a
forall (m :: * -> *) a. Monad m => a -> m a
return) PState
state of
POk PState
state' Located Token
t -> do
if StringBuffer -> Bool
atEnd (PState -> StringBuffer
buffer PState
state') Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
eof
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 [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 a. a -> IO a
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 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]
getMore :: Handle -> PState -> Int -> IO [Located Token]
getMore :: Handle -> PState -> Int -> IO [Located Token]
getMore Handle
handle PState
state Int
size = do
let new_size :: Int
new_size = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
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=newbuf} Bool
False Int
new_size
getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]
getToks :: ParserOpts -> String -> StringBuffer -> [Located Token]
getToks ParserOpts
popts String
filename StringBuffer
buf = PState -> [Located Token]
lexAll PState
pstate
where
pstate :: PState
pstate = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initPragState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc
loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1
lexAll :: PState -> [Located Token]
lexAll PState
state = case P (Located Token) -> PState -> ParseResult (Located Token)
forall a. P a -> PState -> ParseResult a
unP (Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False Located Token -> P (Located Token)
forall 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]
getOptions :: ParserOpts
-> StringBuffer
-> FilePath
-> (Messages PsMessage,[Located String])
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)
getOptions' :: ParserOpts
-> [Located Token]
-> (Messages PsMessage,[Located String])
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
$
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. HasCallStack => String -> Maybe a -> a
expectJust String
"getOptions'" (SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan SrcSpan
src_span)
starting_loc :: RealSrcLoc
starting_loc = RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
real_src_span
parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
| ITinclude_prag String
str <- 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)
| 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
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"
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
[Located String]
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)
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]
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
(String
arg, RealSrcLoc
new_loc, String
rest) <- RealSrcLoc -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
after_spaces_loc String
after_spaces_str
String -> Either String ()
check_for_space String
rest
(RealSrcLoc -> RealSrcLoc -> String -> Located String
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
new_loc 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
new_loc String
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
(String
argPart2, RealSrcLoc
loc3, String
rest) <- RealSrcLoc -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
loc2 String
s''
String -> Either String ()
check_for_space String
rest
(RealSrcLoc -> RealSrcLoc -> String -> Located String
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
loc3 (String
argPart1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
argPart2)Located 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
loc3 String
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)]
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")
readAsList :: RealSrcLoc -> String -> Either String [Located String]
readAsList :: RealSrcLoc -> String -> Either String [Located String]
readAsList RealSrcLoc
loc String
s = do
let (RealSrcLoc
after_spaces_loc, String
after_spaces_str) = RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces RealSrcLoc
loc String
s
(String
arg, RealSrcLoc
after_arg_loc, String
after_arg_str) <- RealSrcLoc -> String -> Either String (String, RealSrcLoc, String)
readAsString RealSrcLoc
after_spaces_loc String
after_spaces_str
let (RealSrcLoc
after_arg_spaces_loc, String
after_arg_spaces_str)
= RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces RealSrcLoc
after_arg_loc String
after_arg_str
(RealSrcLoc -> RealSrcLoc -> String -> Located String
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
after_arg_loc String
arg Located String -> [Located String] -> [Located String]
forall a. a -> [a] -> [a]
:) ([Located String] -> [Located String])
-> Either String [Located String] -> Either String [Located String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
case String
after_arg_spaces_str of
Char
',':String
after_comma -> RealSrcLoc -> String -> Either String [Located String]
readAsList (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
after_arg_spaces_loc Char
',') String
after_comma
Char
']':String
after_bracket
| (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]")
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)
= 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
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
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. 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