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 popts implicit_prelude buf filename source_filename = do
let loc = mkRealSrcLoc (mkFastString filename) 1 1
case unP parseHeader (initParserState popts buf loc) of
PFailed pst ->
return $ Left $ getPsErrorMessages pst
POk pst rdr_module -> fmap Right $ do
let (_warns, errs) = getPsMessages pst
if not (isEmptyMessages errs)
then throwErrors (GhcPsMessage <$> errs)
else
let hsmod = unLoc rdr_module
mb_mod = hsmodName hsmod
imps = hsmodImports hsmod
main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
1 1)
mod = mb_mod `orElse` L (noAnnSrcSpan main_loc) mAIN_NAME
(src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
(ordinary_imps, ghc_prim_import)
= partition ((/= moduleName gHC_PRIM) . unLoc
. ideclName . unLoc)
ord_idecls
implicit_imports = mkPrelImports (unLoc mod) main_loc
implicit_prelude imps
convImport (L _ i) = (ideclPkgQual i, reLoc $ ideclName i)
in
return (map convImport src_idecls
, map convImport (implicit_imports ++ ordinary_imps)
, not (null ghc_prim_import)
, reLoc mod)
mkPrelImports :: ModuleName
-> SrcSpan
-> Bool -> [LImportDecl GhcPs]
-> [LImportDecl GhcPs]
mkPrelImports this_mod loc implicit_prelude import_decls
| this_mod == pRELUDE_NAME
|| explicit_prelude_import
|| not implicit_prelude
= []
| otherwise = [preludeImportDecl]
where
explicit_prelude_import = any is_prelude_import import_decls
is_prelude_import (L _ decl) =
unLoc (ideclName decl) == pRELUDE_NAME
&& case ideclPkgQual decl of
NoRawPkgQual -> True
RawPkgQual b -> sl_fs b == unitIdFS baseUnitId
loc' = noAnnSrcSpan loc
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
= L loc' $ ImportDecl { ideclExt = noAnn,
ideclSourceSrc = NoSourceText,
ideclName = L loc' pRELUDE_NAME,
ideclPkgQual = NoRawPkgQual,
ideclSource = NotBoot,
ideclSafe = False,
ideclQualified = NotQualified,
ideclImplicit = True,
ideclAs = Nothing,
ideclHiding = Nothing }
getOptionsFromFile :: ParserOpts
-> FilePath
-> IO (Messages PsMessage, [Located String])
getOptionsFromFile opts filename
= Exception.bracket
(openBinaryFile filename ReadMode)
(hClose)
(\handle -> do
(warns, opts) <- fmap (getOptions' opts)
(lazyGetToks opts' filename handle)
seqList opts
$ seqList (bagToList $ getMessages warns)
$ return (warns, opts))
where
opts' = disableHaddock opts
blockSize :: Int
blockSize = 1024
lazyGetToks :: ParserOpts -> FilePath -> Handle -> IO [Located Token]
lazyGetToks popts filename handle = do
buf <- hGetStringBufferBlock handle blockSize
let prag_state = initPragState popts buf loc
unsafeInterleaveIO $ lazyLexBuf handle prag_state False blockSize
where
loc = mkRealSrcLoc (mkFastString filename) 1 1
lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]
lazyLexBuf handle state eof size =
case unP (lexer False return) state of
POk state' t -> do
if atEnd (buffer state') && not eof
then getMore handle state size
else case unLoc t of
ITeof -> return [t]
_other -> do rest <- lazyLexBuf handle state' eof size
return (t : rest)
_ | not eof -> getMore handle state size
| otherwise -> return [L (mkSrcSpanPs (last_loc state)) ITeof]
getMore :: Handle -> PState -> Int -> IO [Located Token]
getMore handle state size = do
let new_size = size * 2
nextbuf <- hGetStringBufferBlock handle new_size
if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do
newbuf <- appendStringBuffers (buffer state) nextbuf
unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size
getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]
getToks popts filename buf = lexAll pstate
where
pstate = initPragState popts buf loc
loc = mkRealSrcLoc (mkFastString filename) 1 1
lexAll state = case unP (lexer False return) state of
POk _ t@(L _ ITeof) -> [t]
POk state' t -> t : lexAll state'
_ -> [L (mkSrcSpanPs (last_loc state)) ITeof]
getOptions :: ParserOpts
-> StringBuffer
-> FilePath
-> (Messages PsMessage,[Located String])
getOptions opts buf filename
= getOptions' opts (getToks opts filename buf)
getOptions' :: ParserOpts
-> [Located Token]
-> (Messages PsMessage,[Located String])
getOptions' opts toks
= parseToks toks
where
parseToks (open:close:xs)
| IToptions_prag str <- unLoc open
, ITclose_prag <- unLoc close
= case toArgs starting_loc str of
Left _err -> optionsParseError str $
combineSrcSpans (getLoc open) (getLoc close)
Right args -> fmap (args ++) (parseToks xs)
where
src_span = getLoc open
real_src_span = expectJust "getOptions'" (srcSpanToRealSrcSpan src_span)
starting_loc = realSrcSpanStart real_src_span
parseToks (open:close:xs)
| ITinclude_prag str <- unLoc open
, ITclose_prag <- unLoc close
= fmap (map (L (getLoc open)) ["-#include",removeSpaces str] ++)
(parseToks xs)
parseToks (open:close:xs)
| ITdocOptions str _ <- unLoc open
, ITclose_prag <- unLoc close
= fmap (map (L (getLoc open)) ["-haddock-opts", removeSpaces str] ++)
(parseToks xs)
parseToks (open:xs)
| ITlanguage_prag <- unLoc open
= parseLanguage xs
parseToks (comment:xs)
| isComment (unLoc comment)
= parseToks xs
parseToks xs = (unionManyMessages $ mapMaybe mkMessage xs ,[])
parseLanguage ((L loc (ITconid fs)):rest)
= fmap (checkExtension opts (L loc fs) :) $
case rest of
(L _loc ITcomma):more -> parseLanguage more
(L _loc ITclose_prag):more -> parseToks more
(L loc _):_ -> languagePragParseError loc
[] -> panic "getOptions'.parseLanguage(1) went past eof token"
parseLanguage (tok:_)
= languagePragParseError (getLoc tok)
parseLanguage []
= panic "getOptions'.parseLanguage(2) went past eof token"
mkMessage :: Located Token -> Maybe (Messages PsMessage)
mkMessage (L loc token)
| IToptions_prag _ <- token
= Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma OptionsPrag))
| ITinclude_prag _ <- token
= Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma IncludePrag))
| ITdocOptions _ _ <- token
= Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma DocOptionsPrag))
| ITlanguage_prag <- token
= Just (singleMessage $ mkPlainMsgEnvelope diag_opts loc (PsWarnMisplacedPragma LanguagePrag))
| otherwise = Nothing
where diag_opts = pDiagOpts opts
isComment :: Token -> Bool
isComment c =
case c of
(ITlineComment {}) -> True
(ITblockComment {}) -> True
(ITdocComment {}) -> True
_ -> False
toArgs :: RealSrcLoc
-> String -> Either String
[Located String]
toArgs starting_loc orig_str
= let (after_spaces_loc, after_spaces_str) = consume_spaces starting_loc orig_str in
case after_spaces_str of
'[':after_bracket ->
let after_bracket_loc = advanceSrcLoc after_spaces_loc '['
(after_bracket_spaces_loc, after_bracket_spaces_str)
= consume_spaces after_bracket_loc after_bracket in
case after_bracket_spaces_str of
']':rest | all isSpace rest -> Right []
_ -> readAsList after_bracket_spaces_loc after_bracket_spaces_str
_ -> toArgs' after_spaces_loc after_spaces_str
where
consume_spaces :: RealSrcLoc -> String -> (RealSrcLoc, String)
consume_spaces loc [] = (loc, [])
consume_spaces loc (c:cs)
| isSpace c = consume_spaces (advanceSrcLoc loc c) cs
| otherwise = (loc, c:cs)
break_with_loc :: (Char -> Bool) -> RealSrcLoc -> String
-> (String, RealSrcLoc, String)
break_with_loc p = go []
where
go reversed_acc loc [] = (reverse reversed_acc, loc, [])
go reversed_acc loc (c:cs)
| p c = (reverse reversed_acc, loc, c:cs)
| otherwise = go (c:reversed_acc) (advanceSrcLoc loc c) cs
advance_src_loc_many :: RealSrcLoc -> String -> RealSrcLoc
advance_src_loc_many = foldl' advanceSrcLoc
locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a
locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Strict.Nothing) x
toArgs' :: RealSrcLoc -> String -> Either String [Located String]
toArgs' loc s =
let (after_spaces_loc, after_spaces_str) = consume_spaces loc s in
case after_spaces_str of
[] -> Right []
'"' : _ -> do
(arg, new_loc, rest) <- readAsString after_spaces_loc after_spaces_str
check_for_space rest
(locate after_spaces_loc new_loc arg:)
`fmap` toArgs' new_loc rest
_ -> case break_with_loc (isSpace <||> (== '"')) after_spaces_loc after_spaces_str of
(argPart1, loc2, s''@('"':_)) -> do
(argPart2, loc3, rest) <- readAsString loc2 s''
check_for_space rest
(locate after_spaces_loc loc3 (argPart1 ++ show argPart2):)
`fmap` toArgs' loc3 rest
(arg, loc2, s'') -> (locate after_spaces_loc loc2 arg:)
`fmap` toArgs' loc2 s''
check_for_space :: String -> Either String ()
check_for_space [] = Right ()
check_for_space (c:_)
| isSpace c = Right ()
| otherwise = Left ("Whitespace expected after string in " ++ show orig_str)
reads_with_consumed :: Read a => String
-> [((String, a), String)]
reads_with_consumed = readP_to_S (gather (readPrec_to_P readPrec 0))
readAsString :: RealSrcLoc
-> String
-> Either String (String, RealSrcLoc, String)
readAsString loc s = case reads_with_consumed s of
[((consumed, arg), rest)] ->
Right (arg, advance_src_loc_many loc consumed, rest)
_ ->
Left ("Couldn't read " ++ show s ++ " as String")
readAsList :: RealSrcLoc -> String -> Either String [Located String]
readAsList loc s = do
let (after_spaces_loc, after_spaces_str) = consume_spaces loc s
(arg, after_arg_loc, after_arg_str) <- readAsString after_spaces_loc after_spaces_str
let (after_arg_spaces_loc, after_arg_spaces_str)
= consume_spaces after_arg_loc after_arg_str
(locate after_spaces_loc after_arg_loc arg :) <$>
case after_arg_spaces_str of
',':after_comma -> readAsList (advanceSrcLoc after_arg_spaces_loc ',') after_comma
']':after_bracket
| all isSpace after_bracket
-> Right []
_ -> Left ("Couldn't read " ++ show ('[' : s) ++ " as [String]")
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
checkProcessArgsResult flags
= when (notNull flags) $
liftIO $ throwErrors $ foldMap (singleMessage . mkMsg) flags
where mkMsg (L loc flag)
= mkPlainErrorMsgEnvelope loc $
GhcPsMessage $ PsHeaderMessage $ PsErrUnknownOptionsPragma flag
checkExtension :: ParserOpts -> Located FastString -> Located String
checkExtension opts (L l ext)
= if ext' `elem` (pSupportedExts opts)
then L l ("-X"++ext')
else unsupportedExtnError opts l ext'
where
ext' = unpackFS ext
languagePragParseError :: SrcSpan -> a
languagePragParseError loc =
throwErr loc $ PsErrParseLanguagePragma
unsupportedExtnError :: ParserOpts -> SrcSpan -> String -> a
unsupportedExtnError opts loc unsup =
throwErr loc $ PsErrUnsupportedExt unsup (pSupportedExts opts)
optionsParseError :: String -> SrcSpan -> a
optionsParseError str loc =
throwErr loc $ PsErrParseOptionsPragma str
throwErr :: SrcSpan -> PsHeaderMessage -> a
throwErr loc ps_msg =
let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage (PsHeaderMessage ps_msg)
in throw $ mkSrcErr $ singleMessage msg