{-# LANGUAGE TypeFamilies #-}
module GHC.Parser.Header
( getImports
, mkPrelImports
, getOptionsFromFile
, getOptions
, toArgs
, checkProcessArgsResult
)
where
import GHC.Prelude
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
-> FilePath
-> FilePath
-> IO
(Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
getImports ParserOpts
popts Bool
implicit_prelude StringBuffer
buf FilePath
filename FilePath
source_filename = do
let loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
filename) Int
1 Int
1
case P (Located HsModule) -> PState -> ParseResult (Located HsModule)
forall a. P a -> PState -> ParseResult a
unP P (Located HsModule)
parseHeader (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc) of
PFailed PState
pst ->
Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
(Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
(Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)))
-> Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
(Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
forall a b. (a -> b) -> a -> b
$ Messages PsMessage
-> Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall a b. a -> Either a b
Left (Messages PsMessage
-> Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
-> Messages PsMessage
-> Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall a b. (a -> b) -> a -> b
$ PState -> Messages PsMessage
getPsErrorMessages PState
pst
POk PState
pst Located HsModule
rdr_module -> (([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
-> IO
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
(Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall a b. b -> Either a b
Right (IO
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
(Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)))
-> IO
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
(Either
(Messages PsMessage)
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName))
forall a b. (a -> b) -> a -> b
$ do
let (Messages PsMessage
_warns, Messages PsMessage
errs) = PState -> (Messages PsMessage, Messages PsMessage)
getPsMessages PState
pst
if Bool -> Bool
not (Messages PsMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages PsMessage
errs)
then Messages GhcMessage
-> IO
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage)
-> Messages PsMessage -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsMessage
errs)
else
let hsmod :: HsModule
hsmod = Located HsModule -> HsModule
forall l e. GenLocated l e -> e
unLoc Located HsModule
rdr_module
mb_mod :: Maybe (LocatedA ModuleName)
mb_mod = HsModule -> Maybe (LocatedA ModuleName)
hsmodName HsModule
hsmod
imps :: [LImportDecl GhcPs]
imps = HsModule -> [LImportDecl GhcPs]
hsmodImports HsModule
hsmod
main_loc :: SrcSpan
main_loc = SrcLoc -> SrcSpan
srcLocSpan (FastString -> Int -> Int -> SrcLoc
mkSrcLoc (FilePath -> FastString
mkFastString FilePath
source_filename)
Int
1 Int
1)
mod :: LocatedA ModuleName
mod = Maybe (LocatedA ModuleName)
mb_mod Maybe (LocatedA ModuleName)
-> LocatedA ModuleName -> LocatedA ModuleName
forall a. Maybe a -> a -> a
`orElse` SrcAnn AnnListItem -> ModuleName -> LocatedA ModuleName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcAnn AnnListItem
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
main_loc) ModuleName
mAIN_NAME
([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
src_idecls, [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
ord_idecls) = (GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs) -> Bool)
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> ([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)],
[GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) (IsBootInterface -> Bool)
-> (GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> IsBootInterface)
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> IsBootInterface
forall pass. ImportDecl pass -> IsBootInterface
ideclSource (ImportDecl GhcPs -> IsBootInterface)
-> (GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> ImportDecl GhcPs)
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> IsBootInterface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc) [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
[LImportDecl GhcPs]
imps
([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
ordinary_imps, [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
ghc_prim_import)
= (GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs) -> Bool)
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> ([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)],
[GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
gHC_PRIM) (ModuleName -> Bool)
-> (GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> ModuleName)
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc
(LocatedA ModuleName -> ModuleName)
-> (GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> LocatedA ModuleName)
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl GhcPs -> LocatedA ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName (ImportDecl GhcPs -> LocatedA ModuleName)
-> (GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> ImportDecl GhcPs)
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> LocatedA ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> ImportDecl GhcPs
forall l e. GenLocated l e -> e
unLoc)
[GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
ord_idecls
implicit_imports :: [LImportDecl GhcPs]
implicit_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports (LocatedA ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc LocatedA ModuleName
mod) SrcSpan
main_loc
Bool
implicit_prelude [LImportDecl GhcPs]
imps
convImport :: GenLocated l (ImportDecl pass)
-> (ImportDeclPkgQual pass, Located ModuleName)
convImport (L l
_ ImportDecl pass
i) = (ImportDecl pass -> ImportDeclPkgQual pass
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl pass
i, LocatedAn a ModuleName -> Located ModuleName
forall a e. LocatedAn a e -> Located e
reLoc (LocatedAn a ModuleName -> Located ModuleName)
-> LocatedAn a ModuleName -> Located ModuleName
forall a b. (a -> b) -> a -> b
$ ImportDecl pass -> XRec pass ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
i)
in
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
-> IO
([(RawPkgQual, Located ModuleName)],
[(RawPkgQual, Located ModuleName)], Bool, Located ModuleName)
forall (m :: * -> *) a. Monad m => a -> m a
return ((GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> (RawPkgQual, Located ModuleName))
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> [(RawPkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> (RawPkgQual, Located ModuleName)
forall pass a l.
(XRec pass ModuleName ~ LocatedAn a ModuleName) =>
GenLocated l (ImportDecl pass)
-> (ImportDeclPkgQual pass, Located ModuleName)
convImport [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
src_idecls
, (GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> (RawPkgQual, Located ModuleName))
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> [(RawPkgQual, Located ModuleName)]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
-> (RawPkgQual, Located ModuleName)
forall pass a l.
(XRec pass ModuleName ~ LocatedAn a ModuleName) =>
GenLocated l (ImportDecl pass)
-> (ImportDeclPkgQual pass, Located ModuleName)
convImport ([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
[LImportDecl GhcPs]
implicit_imports [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
ordinary_imps)
, Bool -> Bool
not ([GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
ghc_prim_import)
, LocatedA ModuleName -> Located ModuleName
forall a e. LocatedAn a e -> Located e
reLoc LocatedA ModuleName
mod)
mkPrelImports :: ModuleName
-> SrcSpan
-> 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 (SrcAnn AnnListItem) (ImportDecl GhcPs) -> Bool)
-> [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs) -> Bool
forall pass l l.
(ImportDeclPkgQual pass ~ RawPkgQual,
XRec pass ModuleName ~ GenLocated l ModuleName) =>
GenLocated l (ImportDecl pass) -> Bool
is_prelude_import [GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)]
[LImportDecl GhcPs]
import_decls
is_prelude_import :: GenLocated l (ImportDecl pass) -> Bool
is_prelude_import (L l
_ ImportDecl pass
decl) =
GenLocated l ModuleName -> ModuleName
forall l e. GenLocated l e -> e
unLoc (ImportDecl pass -> XRec pass ModuleName
forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
decl) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME
Bool -> Bool -> Bool
&& case ImportDecl pass -> ImportDeclPkgQual pass
forall pass. ImportDecl pass -> ImportDeclPkgQual pass
ideclPkgQual ImportDecl pass
decl of
ImportDeclPkgQual pass
NoRawPkgQual -> Bool
True
RawPkgQual b -> StringLiteral -> FastString
sl_fs StringLiteral
b FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId -> FastString
unitIdFS UnitId
baseUnitId
loc' :: SrcAnn AnnListItem
loc' = SrcSpan -> SrcAnn AnnListItem
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
= SrcAnn AnnListItem
-> ImportDecl GhcPs
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcAnn AnnListItem
loc' (ImportDecl GhcPs
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs))
-> ImportDecl GhcPs
-> GenLocated (SrcAnn AnnListItem) (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ ImportDecl :: forall pass.
XCImportDecl pass
-> SourceText
-> XRec pass ModuleName
-> ImportDeclPkgQual pass
-> IsBootInterface
-> Bool
-> ImportDeclQualifiedStyle
-> Bool
-> Maybe (XRec pass ModuleName)
-> Maybe (Bool, XRec pass [LIE pass])
-> ImportDecl pass
ImportDecl { ideclExt :: XCImportDecl GhcPs
ideclExt = XCImportDecl GhcPs
forall a. EpAnn a
noAnn,
ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText,
ideclName :: XRec GhcPs ModuleName
ideclName = SrcAnn AnnListItem -> ModuleName -> LocatedA ModuleName
forall l e. l -> e -> GenLocated l e
L SrcAnn AnnListItem
loc' ModuleName
pRELUDE_NAME,
ideclPkgQual :: ImportDeclPkgQual GhcPs
ideclPkgQual = RawPkgQual
ImportDeclPkgQual GhcPs
NoRawPkgQual,
ideclSource :: IsBootInterface
ideclSource = IsBootInterface
NotBoot,
ideclSafe :: Bool
ideclSafe = Bool
False,
ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = ImportDeclQualifiedStyle
NotQualified,
ideclImplicit :: Bool
ideclImplicit = Bool
True,
ideclAs :: Maybe (XRec GhcPs ModuleName)
ideclAs = Maybe (XRec GhcPs ModuleName)
forall a. Maybe a
Nothing,
ideclHiding :: Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclHiding = Maybe (Bool, XRec GhcPs [LIE GhcPs])
forall a. Maybe a
Nothing }
getOptionsFromFile :: ParserOpts
-> FilePath
-> IO [Located String]
getOptionsFromFile :: ParserOpts -> FilePath -> IO [Located FilePath]
getOptionsFromFile ParserOpts
opts FilePath
filename
= IO Handle
-> (Handle -> IO ())
-> (Handle -> IO [Located FilePath])
-> IO [Located FilePath]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
(FilePath -> IOMode -> IO Handle
openBinaryFile FilePath
filename IOMode
ReadMode)
(Handle -> IO ()
hClose)
(\Handle
handle -> do
[Located FilePath]
opts <- ([Located Token] -> [Located FilePath])
-> IO [Located Token] -> IO [Located FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParserOpts -> [Located Token] -> [Located FilePath]
getOptions' ParserOpts
opts)
(ParserOpts -> FilePath -> Handle -> IO [Located Token]
lazyGetToks ParserOpts
opts' FilePath
filename Handle
handle)
[Located FilePath]
-> IO [Located FilePath] -> IO [Located FilePath]
forall a b. [a] -> b -> b
seqList [Located FilePath]
opts (IO [Located FilePath] -> IO [Located FilePath])
-> IO [Located FilePath] -> IO [Located FilePath]
forall a b. (a -> b) -> a -> b
$ [Located FilePath] -> IO [Located FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [Located FilePath]
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 -> FilePath -> Handle -> IO [Located Token]
lazyGetToks ParserOpts
popts FilePath
filename Handle
handle = do
StringBuffer
buf <- Handle -> Int -> IO StringBuffer
hGetStringBufferBlock Handle
handle Int
blockSize
let prag_state :: PState
prag_state = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initPragState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc
IO [Located Token] -> IO [Located Token]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [Located Token] -> IO [Located Token])
-> IO [Located Token] -> IO [Located Token]
forall a b. (a -> b) -> a -> b
$ Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
prag_state Bool
False Int
blockSize
where
loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
filename) Int
1 Int
1
lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state Bool
eof Int
size =
case P (Located Token) -> PState -> ParseResult (Located Token)
forall a. P a -> PState -> ParseResult a
unP (Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False Located Token -> P (Located Token)
forall (m :: * -> *) a. Monad m => a -> m a
return) PState
state of
POk PState
state' Located Token
t -> do
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 (m :: * -> *) a. Monad m => a -> m a
return [Located Token
t]
Token
_other -> do [Located Token]
rest <- Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state' Bool
eof Int
size
[Located Token] -> IO [Located Token]
forall (m :: * -> *) a. Monad m => a -> m a
return (Located Token
t Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: [Located Token]
rest)
ParseResult (Located Token)
_ | Bool -> Bool
not Bool
eof -> Handle -> PState -> Int -> IO [Located Token]
getMore Handle
handle PState
state Int
size
| Bool
otherwise -> [Located Token] -> IO [Located Token]
forall (m :: * -> *) a. Monad m => a -> m a
return [SrcSpan -> Token -> Located Token
forall l e. l -> e -> GenLocated l e
L (PsSpan -> SrcSpan
mkSrcSpanPs (PState -> PsSpan
last_loc PState
state)) Token
ITeof]
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 :: StringBuffer
buffer=StringBuffer
newbuf} Bool
False Int
new_size
getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]
getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]
getToks ParserOpts
popts FilePath
filename StringBuffer
buf = PState -> [Located Token]
lexAll PState
pstate
where
pstate :: PState
pstate = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initPragState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc
loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
mkFastString FilePath
filename) Int
1 Int
1
lexAll :: PState -> [Located Token]
lexAll PState
state = case P (Located Token) -> PState -> ParseResult (Located Token)
forall a. P a -> PState -> ParseResult a
unP (Bool -> (Located Token -> P (Located Token)) -> P (Located Token)
forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False Located Token -> P (Located Token)
forall (m :: * -> *) a. Monad m => a -> m a
return) PState
state of
POk PState
_ t :: Located Token
t@(L SrcSpan
_ Token
ITeof) -> [Located Token
t]
POk PState
state' Located Token
t -> Located Token
t Located Token -> [Located Token] -> [Located Token]
forall a. a -> [a] -> [a]
: PState -> [Located Token]
lexAll PState
state'
ParseResult (Located Token)
_ -> [SrcSpan -> Token -> Located Token
forall l e. l -> e -> GenLocated l e
L (PsSpan -> SrcSpan
mkSrcSpanPs (PState -> PsSpan
last_loc PState
state)) Token
ITeof]
getOptions :: ParserOpts
-> StringBuffer
-> FilePath
-> [Located String]
getOptions :: ParserOpts -> StringBuffer -> FilePath -> [Located FilePath]
getOptions ParserOpts
opts StringBuffer
buf FilePath
filename
= ParserOpts -> [Located Token] -> [Located FilePath]
getOptions' ParserOpts
opts (ParserOpts -> FilePath -> StringBuffer -> [Located Token]
getToks ParserOpts
opts FilePath
filename StringBuffer
buf)
getOptions' :: ParserOpts
-> [Located Token]
-> [Located String]
getOptions' :: ParserOpts -> [Located Token] -> [Located FilePath]
getOptions' ParserOpts
opts [Located Token]
toks
= [Located Token] -> [Located FilePath]
parseToks [Located Token]
toks
where
parseToks :: [Located Token] -> [Located FilePath]
parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
| IToptions_prag FilePath
str <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
open
, Token
ITclose_prag <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
close
= case RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs RealSrcLoc
starting_loc FilePath
str of
Left FilePath
_err -> FilePath -> SrcSpan -> [Located FilePath]
forall a. FilePath -> SrcSpan -> a
optionsParseError FilePath
str (SrcSpan -> [Located FilePath]) -> SrcSpan -> [Located FilePath]
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 FilePath]
args -> [Located FilePath]
args [Located FilePath] -> [Located FilePath] -> [Located FilePath]
forall a. [a] -> [a] -> [a]
++ [Located Token] -> [Located FilePath]
parseToks [Located Token]
xs
where
src_span :: SrcSpan
src_span = Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open
real_src_span :: RealSrcSpan
real_src_span = FilePath -> Maybe RealSrcSpan -> RealSrcSpan
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"getOptions'" (SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan SrcSpan
src_span)
starting_loc :: RealSrcLoc
starting_loc = RealSrcSpan -> RealSrcLoc
realSrcSpanStart RealSrcSpan
real_src_span
parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
| ITinclude_prag FilePath
str <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
open
, Token
ITclose_prag <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
close
= (FilePath -> Located FilePath) -> [FilePath] -> [Located FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> FilePath -> Located FilePath
forall l e. l -> e -> GenLocated l e
L (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open)) [FilePath
"-#include",FilePath -> FilePath
removeSpaces FilePath
str] [Located FilePath] -> [Located FilePath] -> [Located FilePath]
forall a. [a] -> [a] -> [a]
++
[Located Token] -> [Located FilePath]
parseToks [Located Token]
xs
parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
| ITdocOptions FilePath
str PsSpan
_ <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
open
, Token
ITclose_prag <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
close
= (FilePath -> Located FilePath) -> [FilePath] -> [Located FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (SrcSpan -> FilePath -> Located FilePath
forall l e. l -> e -> GenLocated l e
L (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
open)) [FilePath
"-haddock-opts", FilePath -> FilePath
removeSpaces FilePath
str]
[Located FilePath] -> [Located FilePath] -> [Located FilePath]
forall a. [a] -> [a] -> [a]
++ [Located Token] -> [Located FilePath]
parseToks [Located Token]
xs
parseToks (Located Token
open:[Located Token]
xs)
| Token
ITlanguage_prag <- Located Token -> Token
forall l e. GenLocated l e -> e
unLoc Located Token
open
= [Located Token] -> [Located FilePath]
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] -> [Located FilePath]
parseToks [Located Token]
xs
parseToks [Located Token]
_ = []
parseLanguage :: [Located Token] -> [Located FilePath]
parseLanguage ((L SrcSpan
loc (ITconid FastString
fs)):[Located Token]
rest)
= ParserOpts -> Located FastString -> Located FilePath
checkExtension ParserOpts
opts (SrcSpan -> FastString -> Located FastString
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc FastString
fs) Located FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:
case [Located Token]
rest of
(L SrcSpan
_loc Token
ITcomma):[Located Token]
more -> [Located Token] -> [Located FilePath]
parseLanguage [Located Token]
more
(L SrcSpan
_loc Token
ITclose_prag):[Located Token]
more -> [Located Token] -> [Located FilePath]
parseToks [Located Token]
more
(L SrcSpan
loc Token
_):[Located Token]
_ -> SrcSpan -> [Located FilePath]
forall a. SrcSpan -> a
languagePragParseError SrcSpan
loc
[] -> FilePath -> [Located FilePath]
forall a. FilePath -> a
panic FilePath
"getOptions'.parseLanguage(1) went past eof token"
parseLanguage (Located Token
tok:[Located Token]
_)
= SrcSpan -> [Located FilePath]
forall a. SrcSpan -> a
languagePragParseError (Located Token -> SrcSpan
forall l e. GenLocated l e -> l
getLoc Located Token
tok)
parseLanguage []
= FilePath -> [Located FilePath]
forall a. FilePath -> a
panic FilePath
"getOptions'.parseLanguage(2) went past eof token"
isComment :: Token -> Bool
isComment :: Token -> Bool
isComment Token
c =
case Token
c of
(ITlineComment {}) -> Bool
True
(ITblockComment {}) -> Bool
True
(ITdocCommentNext {}) -> Bool
True
(ITdocCommentPrev {}) -> Bool
True
(ITdocCommentNamed {}) -> Bool
True
(ITdocSection {}) -> Bool
True
Token
_ -> Bool
False
toArgs :: RealSrcLoc
-> String -> Either String
[Located String]
toArgs :: RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs RealSrcLoc
starting_loc FilePath
orig_str
= let (RealSrcLoc
after_spaces_loc, FilePath
after_spaces_str) = RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
starting_loc FilePath
orig_str in
case FilePath
after_spaces_str of
Char
'[':FilePath
after_bracket ->
let after_bracket_loc :: RealSrcLoc
after_bracket_loc = RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
after_spaces_loc Char
'['
(RealSrcLoc
after_bracket_spaces_loc, FilePath
after_bracket_spaces_str)
= RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
after_bracket_loc FilePath
after_bracket in
case FilePath
after_bracket_spaces_str of
Char
']':FilePath
rest | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace FilePath
rest -> [Located FilePath] -> Either FilePath [Located FilePath]
forall a b. b -> Either a b
Right []
FilePath
_ -> RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
readAsList RealSrcLoc
after_bracket_spaces_loc FilePath
after_bracket_spaces_str
FilePath
_ -> RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs' RealSrcLoc
after_spaces_loc FilePath
after_spaces_str
where
consume_spaces :: RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces :: RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
loc [] = (RealSrcLoc
loc, [])
consume_spaces RealSrcLoc
loc (Char
c:FilePath
cs)
| Char -> Bool
isSpace Char
c = RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
loc Char
c) FilePath
cs
| Bool
otherwise = (RealSrcLoc
loc, Char
cChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
cs)
break_with_loc :: (Char -> Bool) -> RealSrcLoc -> String
-> (String, RealSrcLoc, String)
break_with_loc :: (Char -> Bool)
-> RealSrcLoc -> FilePath -> (FilePath, RealSrcLoc, FilePath)
break_with_loc Char -> Bool
p = FilePath
-> RealSrcLoc -> FilePath -> (FilePath, RealSrcLoc, FilePath)
go []
where
go :: FilePath
-> RealSrcLoc -> FilePath -> (FilePath, RealSrcLoc, FilePath)
go FilePath
reversed_acc RealSrcLoc
loc [] = (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
reversed_acc, RealSrcLoc
loc, [])
go FilePath
reversed_acc RealSrcLoc
loc (Char
c:FilePath
cs)
| Char -> Bool
p Char
c = (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
reversed_acc, RealSrcLoc
loc, Char
cChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
cs)
| Bool
otherwise = FilePath
-> RealSrcLoc -> FilePath -> (FilePath, RealSrcLoc, FilePath)
go (Char
cChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
reversed_acc) (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
loc Char
c) FilePath
cs
advance_src_loc_many :: RealSrcLoc -> String -> RealSrcLoc
advance_src_loc_many :: RealSrcLoc -> FilePath -> RealSrcLoc
advance_src_loc_many = (RealSrcLoc -> Char -> RealSrcLoc)
-> RealSrcLoc -> FilePath -> RealSrcLoc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc
locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a
locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
begin RealSrcLoc
end a
x = SrcSpan -> a -> Located a
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
begin RealSrcLoc
end) Maybe BufSpan
forall a. Maybe a
Strict.Nothing) a
x
toArgs' :: RealSrcLoc -> String -> Either String [Located String]
toArgs' :: RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs' RealSrcLoc
loc FilePath
s =
let (RealSrcLoc
after_spaces_loc, FilePath
after_spaces_str) = RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
loc FilePath
s in
case FilePath
after_spaces_str of
[] -> [Located FilePath] -> Either FilePath [Located FilePath]
forall a b. b -> Either a b
Right []
Char
'"' : FilePath
_ -> do
(FilePath
arg, RealSrcLoc
new_loc, FilePath
rest) <- RealSrcLoc
-> FilePath -> Either FilePath (FilePath, RealSrcLoc, FilePath)
readAsString RealSrcLoc
after_spaces_loc FilePath
after_spaces_str
FilePath -> Either FilePath ()
check_for_space FilePath
rest
(RealSrcLoc -> RealSrcLoc -> FilePath -> Located FilePath
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
new_loc FilePath
argLocated FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:)
([Located FilePath] -> [Located FilePath])
-> Either FilePath [Located FilePath]
-> Either FilePath [Located FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs' RealSrcLoc
new_loc FilePath
rest
FilePath
_ -> case (Char -> Bool)
-> RealSrcLoc -> FilePath -> (FilePath, RealSrcLoc, FilePath)
break_with_loc (Char -> Bool
isSpace (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"')) RealSrcLoc
after_spaces_loc FilePath
after_spaces_str of
(FilePath
argPart1, RealSrcLoc
loc2, s'' :: FilePath
s''@(Char
'"':FilePath
_)) -> do
(FilePath
argPart2, RealSrcLoc
loc3, FilePath
rest) <- RealSrcLoc
-> FilePath -> Either FilePath (FilePath, RealSrcLoc, FilePath)
readAsString RealSrcLoc
loc2 FilePath
s''
FilePath -> Either FilePath ()
check_for_space FilePath
rest
(RealSrcLoc -> RealSrcLoc -> FilePath -> Located FilePath
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
loc3 (FilePath
argPart1 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
argPart2)Located FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:)
([Located FilePath] -> [Located FilePath])
-> Either FilePath [Located FilePath]
-> Either FilePath [Located FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs' RealSrcLoc
loc3 FilePath
rest
(FilePath
arg, RealSrcLoc
loc2, FilePath
s'') -> (RealSrcLoc -> RealSrcLoc -> FilePath -> Located FilePath
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
loc2 FilePath
argLocated FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:)
([Located FilePath] -> [Located FilePath])
-> Either FilePath [Located FilePath]
-> Either FilePath [Located FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
toArgs' RealSrcLoc
loc2 FilePath
s''
check_for_space :: String -> Either String ()
check_for_space :: FilePath -> Either FilePath ()
check_for_space [] = () -> Either FilePath ()
forall a b. b -> Either a b
Right ()
check_for_space (Char
c:FilePath
_)
| Char -> Bool
isSpace Char
c = () -> Either FilePath ()
forall a b. b -> Either a b
Right ()
| Bool
otherwise = FilePath -> Either FilePath ()
forall a b. a -> Either a b
Left (FilePath
"Whitespace expected after string in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
orig_str)
reads_with_consumed :: Read a => String
-> [((String, a), String)]
reads_with_consumed :: FilePath -> [((FilePath, a), FilePath)]
reads_with_consumed = ReadP (FilePath, a) -> FilePath -> [((FilePath, a), FilePath)]
forall a. ReadP a -> ReadS a
readP_to_S (ReadP a -> ReadP (FilePath, a)
forall a. ReadP a -> ReadP (FilePath, a)
gather (ReadPrec a -> Int -> ReadP a
forall a. ReadPrec a -> Int -> ReadP a
readPrec_to_P ReadPrec a
forall a. Read a => ReadPrec a
readPrec Int
0))
readAsString :: RealSrcLoc
-> String
-> Either String (String, RealSrcLoc, String)
readAsString :: RealSrcLoc
-> FilePath -> Either FilePath (FilePath, RealSrcLoc, FilePath)
readAsString RealSrcLoc
loc FilePath
s = case FilePath -> [((FilePath, FilePath), FilePath)]
forall a. Read a => FilePath -> [((FilePath, a), FilePath)]
reads_with_consumed FilePath
s of
[((FilePath
consumed, FilePath
arg), FilePath
rest)] ->
(FilePath, RealSrcLoc, FilePath)
-> Either FilePath (FilePath, RealSrcLoc, FilePath)
forall a b. b -> Either a b
Right (FilePath
arg, RealSrcLoc -> FilePath -> RealSrcLoc
advance_src_loc_many RealSrcLoc
loc FilePath
consumed, FilePath
rest)
[((FilePath, FilePath), FilePath)]
_ ->
FilePath -> Either FilePath (FilePath, RealSrcLoc, FilePath)
forall a b. a -> Either a b
Left (FilePath
"Couldn't read " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" as String")
readAsList :: RealSrcLoc -> String -> Either String [Located String]
readAsList :: RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
readAsList RealSrcLoc
loc FilePath
s = do
let (RealSrcLoc
after_spaces_loc, FilePath
after_spaces_str) = RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
loc FilePath
s
(FilePath
arg, RealSrcLoc
after_arg_loc, FilePath
after_arg_str) <- RealSrcLoc
-> FilePath -> Either FilePath (FilePath, RealSrcLoc, FilePath)
readAsString RealSrcLoc
after_spaces_loc FilePath
after_spaces_str
let (RealSrcLoc
after_arg_spaces_loc, FilePath
after_arg_spaces_str)
= RealSrcLoc -> FilePath -> (RealSrcLoc, FilePath)
consume_spaces RealSrcLoc
after_arg_loc FilePath
after_arg_str
(RealSrcLoc -> RealSrcLoc -> FilePath -> Located FilePath
forall a. RealSrcLoc -> RealSrcLoc -> a -> Located a
locate RealSrcLoc
after_spaces_loc RealSrcLoc
after_arg_loc FilePath
arg Located FilePath -> [Located FilePath] -> [Located FilePath]
forall a. a -> [a] -> [a]
:) ([Located FilePath] -> [Located FilePath])
-> Either FilePath [Located FilePath]
-> Either FilePath [Located FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
case FilePath
after_arg_spaces_str of
Char
',':FilePath
after_comma -> RealSrcLoc -> FilePath -> Either FilePath [Located FilePath]
readAsList (RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc RealSrcLoc
after_arg_spaces_loc Char
',') FilePath
after_comma
Char
']':FilePath
after_bracket
| (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace FilePath
after_bracket
-> [Located FilePath] -> Either FilePath [Located FilePath]
forall a b. b -> Either a b
Right []
FilePath
_ -> FilePath -> Either FilePath [Located FilePath]
forall a b. a -> Either a b
Left (FilePath
"Couldn't read " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show (Char
'[' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
s) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" as [String]")
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
checkProcessArgsResult :: [Located FilePath] -> m ()
checkProcessArgsResult [Located FilePath]
flags
= Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Located FilePath] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Located FilePath]
flags) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> IO ()
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (Messages GhcMessage -> IO ()) -> Messages GhcMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ (Located FilePath -> Messages GhcMessage)
-> [Located FilePath] -> Messages GhcMessage
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> (Located FilePath -> MsgEnvelope GhcMessage)
-> Located FilePath
-> Messages GhcMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located FilePath -> MsgEnvelope GhcMessage
mkMsg) [Located FilePath]
flags
where mkMsg :: Located FilePath -> MsgEnvelope GhcMessage
mkMsg (L SrcSpan
loc FilePath
flag)
= SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
PsMessage -> GhcMessage
GhcPsMessage (PsMessage -> GhcMessage) -> PsMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ PsHeaderMessage -> PsMessage
PsHeaderMessage (PsHeaderMessage -> PsMessage) -> PsHeaderMessage -> PsMessage
forall a b. (a -> b) -> a -> b
$ FilePath -> PsHeaderMessage
PsErrUnknownOptionsPragma FilePath
flag
checkExtension :: ParserOpts -> Located FastString -> Located String
checkExtension :: ParserOpts -> Located FastString -> Located FilePath
checkExtension ParserOpts
opts (L SrcSpan
l FastString
ext)
= if FilePath
ext' FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ParserOpts -> [FilePath]
pSupportedExts ParserOpts
opts)
then SrcSpan -> FilePath -> Located FilePath
forall l e. l -> e -> GenLocated l e
L SrcSpan
l (FilePath
"-X"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
ext')
else ParserOpts -> SrcSpan -> FilePath -> Located FilePath
forall a. ParserOpts -> SrcSpan -> FilePath -> a
unsupportedExtnError ParserOpts
opts SrcSpan
l FilePath
ext'
where
ext' :: FilePath
ext' = FastString -> FilePath
unpackFS FastString
ext
languagePragParseError :: SrcSpan -> a
languagePragParseError :: SrcSpan -> a
languagePragParseError SrcSpan
loc =
SrcSpan -> PsHeaderMessage -> a
forall a. SrcSpan -> PsHeaderMessage -> a
throwErr SrcSpan
loc (PsHeaderMessage -> a) -> PsHeaderMessage -> a
forall a b. (a -> b) -> a -> b
$ PsHeaderMessage
PsErrParseLanguagePragma
unsupportedExtnError :: ParserOpts -> SrcSpan -> String -> a
unsupportedExtnError :: ParserOpts -> SrcSpan -> FilePath -> a
unsupportedExtnError ParserOpts
opts SrcSpan
loc FilePath
unsup =
SrcSpan -> PsHeaderMessage -> a
forall a. SrcSpan -> PsHeaderMessage -> a
throwErr SrcSpan
loc (PsHeaderMessage -> a) -> PsHeaderMessage -> a
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> PsHeaderMessage
PsErrUnsupportedExt FilePath
unsup (ParserOpts -> [FilePath]
pSupportedExts ParserOpts
opts)
optionsParseError :: String -> SrcSpan -> a
optionsParseError :: FilePath -> SrcSpan -> a
optionsParseError FilePath
str SrcSpan
loc =
SrcSpan -> PsHeaderMessage -> a
forall a. SrcSpan -> PsHeaderMessage -> a
throwErr SrcSpan
loc (PsHeaderMessage -> a) -> PsHeaderMessage -> a
forall a b. (a -> b) -> a -> b
$ FilePath -> PsHeaderMessage
PsErrParseOptionsPragma FilePath
str
throwErr :: SrcSpan -> PsHeaderMessage -> a
throwErr :: SrcSpan -> PsHeaderMessage -> a
throwErr SrcSpan
loc PsHeaderMessage
ps_msg =
let msg :: MsgEnvelope GhcMessage
msg = SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
loc (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ PsMessage -> GhcMessage
GhcPsMessage (PsHeaderMessage -> PsMessage
PsHeaderMessage PsHeaderMessage
ps_msg)
in SourceError -> a
forall a e. Exception e => e -> a
throw (SourceError -> a) -> SourceError -> a
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> SourceError
mkSrcErr (Messages GhcMessage -> SourceError)
-> Messages GhcMessage -> SourceError
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage MsgEnvelope GhcMessage
msg