{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Parser.Header
( getImports
, mkPrelImports
, getOptionsFromFile
, getOptions
, optionsErrorMsgs
, checkProcessArgsResult
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Driver.Session
import GHC.Driver.Config
import GHC.Parser.Errors.Ppr
import GHC.Parser.Errors
import GHC.Parser ( parseHeader )
import GHC.Parser.Lexer
import GHC.Hs
import GHC.Unit.Module
import GHC.Builtin.Names
import GHC.Types.Error hiding ( getErrorMessages, getWarningMessages )
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.SourceText
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
import GHC.Utils.Monad
import GHC.Utils.Exception as Exception
import GHC.Data.StringBuffer
import GHC.Data.Maybe
import GHC.Data.Bag ( Bag, listToBag, unitBag, isEmptyBag )
import GHC.Data.FastString
import Control.Monad
import System.IO
import System.IO.Unsafe
import Data.List (partition)
getImports :: ParserOpts
-> Bool
-> StringBuffer
-> FilePath
-> FilePath
-> IO (Either
(Bag PsError)
([(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)],
Located ModuleName))
getImports :: ParserOpts
-> Bool
-> StringBuffer
-> String
-> String
-> IO
(Either
(Bag PsError)
([(Maybe FastString, Located ModuleName)],
[(Maybe FastString, Located ModuleName)], Located ModuleName))
getImports ParserOpts
popts Bool
implicit_prelude StringBuffer
buf String
filename String
source_filename = do
let loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1
case forall a. P a -> PState -> ParseResult a
unP P (Located HsModule)
parseHeader (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc) of
PFailed PState
pst ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ PState -> Bag PsError
getErrorMessages PState
pst
POk PState
pst Located HsModule
rdr_module -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ do
let (Bag PsWarning
_warns, Bag PsError
errs) = PState -> (Bag PsWarning, Bag PsError)
getMessages PState
pst
if Bool -> Bool
not (forall a. Bag a -> Bool
isEmptyBag Bag PsError
errs)
then forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ ErrorMessages -> SourceError
mkSrcErr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError Bag PsError
errs)
else
let hsmod :: HsModule
hsmod = forall l e. GenLocated l e -> e
unLoc Located HsModule
rdr_module
mb_mod :: Maybe (GenLocated SrcSpanAnnA ModuleName)
mb_mod = HsModule -> Maybe (GenLocated SrcSpanAnnA 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 (String -> FastString
mkFastString String
source_filename)
Int
1 Int
1)
mod :: GenLocated SrcSpanAnnA ModuleName
mod = Maybe (GenLocated SrcSpanAnnA ModuleName)
mb_mod forall a. Maybe a -> a -> a
`orElse` forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
main_loc) ModuleName
mAIN_NAME
([GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls, [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> IsBootInterface
ideclSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LImportDecl GhcPs]
imps
ordinary_imps :: [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= forall unit. GenModule unit -> ModuleName
moduleName Module
gHC_PRIM) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc)
[GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ord_idecls
implicit_imports :: [LImportDecl GhcPs]
implicit_imports = ModuleName
-> SrcSpan -> Bool -> [LImportDecl GhcPs] -> [LImportDecl GhcPs]
mkPrelImports (forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA ModuleName
mod) SrcSpan
main_loc
Bool
implicit_prelude [LImportDecl GhcPs]
imps
convImport :: GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport (L l
_ ImportDecl pass
i) = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StringLiteral -> FastString
sl_fs (forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl pass
i), forall a e. LocatedAn a e -> Located e
reLoc (forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
i))
in
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
src_idecls,
forall a b. (a -> b) -> [a] -> [b]
map forall {pass} {a} {l}.
(XRec pass ModuleName ~ GenLocated (SrcAnn a) ModuleName) =>
GenLocated l (ImportDecl pass)
-> (Maybe FastString, Located ModuleName)
convImport ([LImportDecl GhcPs]
implicit_imports forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (ImportDecl GhcPs)]
ordinary_imps),
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 forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME
Bool -> Bool -> Bool
|| Bool
explicit_prelude_import
Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
implicit_prelude
= []
| Bool
otherwise = [LImportDecl GhcPs
preludeImportDecl]
where
explicit_prelude_import :: Bool
explicit_prelude_import = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {pass} {l} {l}.
(XRec pass ModuleName ~ GenLocated l ModuleName) =>
GenLocated l (ImportDecl pass) -> Bool
is_prelude_import [LImportDecl GhcPs]
import_decls
is_prelude_import :: GenLocated l (ImportDecl pass) -> Bool
is_prelude_import (L l
_ ImportDecl pass
decl) =
forall l e. GenLocated l e -> e
unLoc (forall pass. ImportDecl pass -> XRec pass ModuleName
ideclName ImportDecl pass
decl) forall a. Eq a => a -> a -> Bool
== ModuleName
pRELUDE_NAME
Bool -> Bool -> Bool
&& case forall pass. ImportDecl pass -> Maybe StringLiteral
ideclPkgQual ImportDecl pass
decl of
Maybe StringLiteral
Nothing -> Bool
True
Just StringLiteral
b -> StringLiteral -> FastString
sl_fs StringLiteral
b forall a. Eq a => a -> a -> Bool
== UnitId -> FastString
unitIdFS UnitId
baseUnitId
loc' :: SrcSpanAnnA
loc' = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
= forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' forall a b. (a -> b) -> a -> b
$ ImportDecl { ideclExt :: XCImportDecl GhcPs
ideclExt = forall a. EpAnn a
noAnn,
ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText,
ideclName :: XRec GhcPs ModuleName
ideclName = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' ModuleName
pRELUDE_NAME,
ideclPkgQual :: Maybe StringLiteral
ideclPkgQual = forall a. Maybe a
Nothing,
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 = forall a. Maybe a
Nothing,
ideclHiding :: Maybe (Bool, XRec GhcPs [LIE GhcPs])
ideclHiding = forall a. Maybe a
Nothing }
getOptionsFromFile :: DynFlags
-> FilePath
-> IO [Located String]
getOptionsFromFile :: DynFlags -> String -> IO [Located String]
getOptionsFromFile DynFlags
dflags String
filename
= forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exception.bracket
(String -> IOMode -> IO Handle
openBinaryFile String
filename IOMode
ReadMode)
(Handle -> IO ()
hClose)
(\Handle
handle -> do
[Located String]
opts <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DynFlags -> [Located Token] -> [Located String]
getOptions' DynFlags
dflags)
(ParserOpts -> String -> Handle -> IO [Located Token]
lazyGetToks (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags') String
filename Handle
handle)
forall a b. [a] -> b -> b
seqList [Located String]
opts forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return [Located String]
opts)
where
dflags' :: DynFlags
dflags' = DynFlags -> GeneralFlag -> DynFlags
gopt_unset DynFlags
dflags GeneralFlag
Opt_Haddock
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
forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
prag_state Bool
False Int
blockSize
where
loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1
lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state Bool
eof Int
size =
case forall a. P a -> PState -> ParseResult a
unP (forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False forall (m :: * -> *) a. Monad m => a -> m a
return) PState
state of
POk PState
state' Located Token
t -> do
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 forall l e. GenLocated l e -> e
unLoc Located Token
t of
Token
ITeof -> forall (m :: * -> *) a. Monad m => a -> m a
return [Located Token
t]
Token
_other -> do [Located Token]
rest <- Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state' Bool
eof Int
size
forall (m :: * -> *) a. Monad m => a -> m a
return (Located Token
t forall a. a -> [a] -> [a]
: [Located Token]
rest)
ParseResult (Located Token)
_ | Bool -> Bool
not Bool
eof -> Handle -> PState -> Int -> IO [Located Token]
getMore Handle
handle PState
state Int
size
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return [forall l e. l -> e -> GenLocated l e
L (PsSpan -> SrcSpan
mkSrcSpanPs (PState -> PsSpan
last_loc PState
state)) Token
ITeof]
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 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 forall a. Eq a => a -> a -> Bool
== Int
0) then Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state Bool
True Int
new_size else do
StringBuffer
newbuf <- StringBuffer -> StringBuffer -> IO StringBuffer
appendStringBuffers (PState -> StringBuffer
buffer PState
state) StringBuffer
nextbuf
forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf Handle
handle PState
state{buffer :: StringBuffer
buffer=StringBuffer
newbuf} Bool
False Int
new_size
getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]
getToks :: ParserOpts -> String -> StringBuffer -> [Located Token]
getToks ParserOpts
popts String
filename StringBuffer
buf = PState -> [Located Token]
lexAll PState
pstate
where
pstate :: PState
pstate = ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initPragState ParserOpts
popts StringBuffer
buf RealSrcLoc
loc
loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1
lexAll :: PState -> [Located Token]
lexAll PState
state = case forall a. P a -> PState -> ParseResult a
unP (forall a. Bool -> (Located Token -> P a) -> P a
lexer Bool
False forall (m :: * -> *) a. Monad m => a -> m a
return) PState
state of
POk PState
_ t :: Located Token
t@(L SrcSpan
_ Token
ITeof) -> [Located Token
t]
POk PState
state' Located Token
t -> Located Token
t forall a. a -> [a] -> [a]
: PState -> [Located Token]
lexAll PState
state'
ParseResult (Located Token)
_ -> [forall l e. l -> e -> GenLocated l e
L (PsSpan -> SrcSpan
mkSrcSpanPs (PState -> PsSpan
last_loc PState
state)) Token
ITeof]
getOptions :: DynFlags
-> StringBuffer
-> FilePath
-> [Located String]
getOptions :: DynFlags -> StringBuffer -> String -> [Located String]
getOptions DynFlags
dflags StringBuffer
buf String
filename
= DynFlags -> [Located Token] -> [Located String]
getOptions' DynFlags
dflags (ParserOpts -> String -> StringBuffer -> [Located Token]
getToks (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) String
filename StringBuffer
buf)
getOptions' :: DynFlags
-> [Located Token]
-> [Located String]
getOptions' :: DynFlags -> [Located Token] -> [Located String]
getOptions' DynFlags
dflags [Located Token]
toks
= [Located Token] -> [Located String]
parseToks [Located Token]
toks
where
parseToks :: [Located Token] -> [Located String]
parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
| IToptions_prag String
str <- forall l e. GenLocated l e -> e
unLoc Located Token
open
, Token
ITclose_prag <- forall l e. GenLocated l e -> e
unLoc Located Token
close
= case String -> Either String [String]
toArgs String
str of
Left String
_err -> forall a. String -> SrcSpan -> a
optionsParseError String
str forall a b. (a -> b) -> a -> b
$
SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (forall l e. GenLocated l e -> l
getLoc Located Token
open) (forall l e. GenLocated l e -> l
getLoc Located Token
close)
Right [String]
args -> forall a b. (a -> b) -> [a] -> [b]
map (forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc Located Token
open)) [String]
args forall a. [a] -> [a] -> [a]
++ [Located Token] -> [Located String]
parseToks [Located Token]
xs
parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
| ITinclude_prag String
str <- forall l e. GenLocated l e -> e
unLoc Located Token
open
, Token
ITclose_prag <- forall l e. GenLocated l e -> e
unLoc Located Token
close
= forall a b. (a -> b) -> [a] -> [b]
map (forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc Located Token
open)) [String
"-#include",String -> String
removeSpaces String
str] forall a. [a] -> [a] -> [a]
++
[Located Token] -> [Located String]
parseToks [Located Token]
xs
parseToks (Located Token
open:Located Token
close:[Located Token]
xs)
| ITdocOptions String
str PsSpan
_ <- forall l e. GenLocated l e -> e
unLoc Located Token
open
, Token
ITclose_prag <- forall l e. GenLocated l e -> e
unLoc Located Token
close
= forall a b. (a -> b) -> [a] -> [b]
map (forall l e. l -> e -> GenLocated l e
L (forall l e. GenLocated l e -> l
getLoc Located Token
open)) [String
"-haddock-opts", String -> String
removeSpaces String
str]
forall a. [a] -> [a] -> [a]
++ [Located Token] -> [Located String]
parseToks [Located Token]
xs
parseToks (Located Token
open:[Located Token]
xs)
| Token
ITlanguage_prag <- forall l e. GenLocated l e -> e
unLoc Located Token
open
= [Located Token] -> [Located String]
parseLanguage [Located Token]
xs
parseToks (Located Token
comment:[Located Token]
xs)
| Token -> Bool
isComment (forall l e. GenLocated l e -> e
unLoc Located Token
comment)
= [Located Token] -> [Located String]
parseToks [Located Token]
xs
parseToks [Located Token]
_ = []
parseLanguage :: [Located Token] -> [Located String]
parseLanguage ((L SrcSpan
loc (ITconid FastString
fs)):[Located Token]
rest)
= DynFlags -> Located FastString -> Located String
checkExtension DynFlags
dflags (forall l e. l -> e -> GenLocated l e
L SrcSpan
loc FastString
fs) forall a. a -> [a] -> [a]
:
case [Located Token]
rest of
(L SrcSpan
_loc Token
ITcomma):[Located Token]
more -> [Located Token] -> [Located String]
parseLanguage [Located Token]
more
(L SrcSpan
_loc Token
ITclose_prag):[Located Token]
more -> [Located Token] -> [Located String]
parseToks [Located Token]
more
(L SrcSpan
loc Token
_):[Located Token]
_ -> forall a. SrcSpan -> a
languagePragParseError SrcSpan
loc
[] -> forall a. String -> a
panic String
"getOptions'.parseLanguage(1) went past eof token"
parseLanguage (Located Token
tok:[Located Token]
_)
= forall a. SrcSpan -> a
languagePragParseError (forall l e. GenLocated l e -> l
getLoc Located Token
tok)
parseLanguage []
= forall a. String -> a
panic String
"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
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
checkProcessArgsResult :: forall (m :: * -> *). MonadIO m => [Located String] -> m ()
checkProcessArgsResult [Located String]
flags
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [Located String]
flags) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ ErrorMessages -> SourceError
mkSrcErr forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Bag a
listToBag forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Located String -> MsgEnvelope DecoratedSDoc
mkMsg [Located String]
flags
where mkMsg :: Located String -> MsgEnvelope DecoratedSDoc
mkMsg (L SrcSpan
loc String
flag)
= SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc forall a b. (a -> b) -> a -> b
$
(String -> SDoc
text String
"unknown flag in {-# OPTIONS_GHC #-} pragma:" SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
flag)
checkExtension :: DynFlags -> Located FastString -> Located String
checkExtension :: DynFlags -> Located FastString -> Located String
checkExtension DynFlags
dflags (L SrcSpan
l FastString
ext)
= if String
ext' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
supported
then forall l e. l -> e -> GenLocated l e
L SrcSpan
l (String
"-X"forall a. [a] -> [a] -> [a]
++String
ext')
else forall a. DynFlags -> SrcSpan -> String -> a
unsupportedExtnError DynFlags
dflags SrcSpan
l String
ext'
where
ext' :: String
ext' = FastString -> String
unpackFS FastString
ext
supported :: [String]
supported = ArchOS -> [String]
supportedLanguagesAndExtensions forall a b. (a -> b) -> a -> b
$ Platform -> ArchOS
platformArchOS forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
languagePragParseError :: SrcSpan -> a
languagePragParseError :: forall a. SrcSpan -> a
languagePragParseError SrcSpan
loc =
forall a. SrcSpan -> SDoc -> a
throwErr SrcSpan
loc forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Cannot parse LANGUAGE pragma"
, String -> SDoc
text String
"Expecting comma-separated list of language options,"
, String -> SDoc
text String
"each starting with a capital letter"
, Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]
unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
unsupportedExtnError :: forall a. DynFlags -> SrcSpan -> String -> a
unsupportedExtnError DynFlags
dflags SrcSpan
loc String
unsup =
forall a. SrcSpan -> SDoc -> a
throwErr SrcSpan
loc forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Unsupported extension: " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
unsup SDoc -> SDoc -> SDoc
$$
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
suggestions then SDoc
Outputable.empty else String -> SDoc
text String
"Perhaps you meant" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
quotedListWithOr (forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text [String]
suggestions)
where
supported :: [String]
supported = ArchOS -> [String]
supportedLanguagesAndExtensions forall a b. (a -> b) -> a -> b
$ Platform -> ArchOS
platformArchOS forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
suggestions :: [String]
suggestions = String -> [String] -> [String]
fuzzyMatch String
unsup [String]
supported
optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DecoratedSDoc
optionsErrorMsgs :: [String] -> [Located String] -> String -> Messages DecoratedSDoc
optionsErrorMsgs [String]
unhandled_flags [Located String]
flags_lines String
_filename
= forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Bag a
listToBag (forall a b. (a -> b) -> [a] -> [b]
map Located String -> MsgEnvelope DecoratedSDoc
mkMsg [Located String]
unhandled_flags_lines)
where unhandled_flags_lines :: [Located String]
unhandled_flags_lines :: [Located String]
unhandled_flags_lines = [ forall l e. l -> e -> GenLocated l e
L SrcSpan
l String
f
| String
f <- [String]
unhandled_flags
, L SrcSpan
l String
f' <- [Located String]
flags_lines
, String
f forall a. Eq a => a -> a -> Bool
== String
f' ]
mkMsg :: Located String -> MsgEnvelope DecoratedSDoc
mkMsg (L SrcSpan
flagSpan String
flag) =
SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
flagSpan forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"unknown flag in {-# OPTIONS_GHC #-} pragma:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
flag
optionsParseError :: String -> SrcSpan -> a
optionsParseError :: forall a. String -> SrcSpan -> a
optionsParseError String
str SrcSpan
loc =
forall a. SrcSpan -> SDoc -> a
throwErr SrcSpan
loc forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Error while parsing OPTIONS_GHC pragma."
, String -> SDoc
text String
"Expecting whitespace-separated list of GHC options."
, String -> SDoc
text String
" E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
, String -> SDoc
text (String
"Input was: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
str) ]
throwErr :: SrcSpan -> SDoc -> a
throwErr :: forall a. SrcSpan -> SDoc -> a
throwErr SrcSpan
loc SDoc
doc =
forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ ErrorMessages -> SourceError
mkSrcErr forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
loc SDoc
doc