module HeaderInfo ( getImports
, mkPrelImports
, getOptionsFromFile, getOptions
, optionsErrorMsgs,
checkProcessArgsResult ) where
#include "HsVersions.h"
import RdrName
import HscTypes
import Parser ( parseHeader )
import Lexer
import FastString
import HsSyn
import Module
import PrelNames
import StringBuffer
import SrcLoc
import DynFlags
import ErrUtils
import Util
import Outputable
import Pretty ()
import Maybes
import Bag ( emptyBag, listToBag, unitBag )
import MonadUtils ( MonadIO )
import Exception
import Control.Monad
import System.IO
import System.IO.Unsafe
import Data.List
getImports :: GhcMonad m =>
DynFlags
-> StringBuffer
-> FilePath
-> FilePath
-> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
getImports dflags buf filename source_filename = do
let loc = mkSrcLoc (mkFastString filename) 1 1
case unP parseHeader (mkPState dflags buf loc) of
PFailed span err -> parseError span err
POk pst rdr_module -> do
let _ms@(_warns, errs) = getMessages pst
ms = (emptyBag, errs)
if errorsFound dflags ms
then liftIO $ throwIO $ mkSrcErr errs
else
case rdr_module of
L _ (HsModule mb_mod _ imps _ _ _) ->
let
main_loc = mkSrcLoc (mkFastString source_filename) 1 1
mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME
(src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
ord_idecls
implicit_prelude = xopt Opt_ImplicitPrelude dflags
implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps
in
return (src_idecls, implicit_imports ++ ordinary_imps, mod)
mkPrelImports :: ModuleName -> Bool -> [LImportDecl RdrName]
-> [LImportDecl RdrName]
mkPrelImports this_mod implicit_prelude import_decls
| this_mod == pRELUDE_NAME
|| explicit_prelude_import
|| not implicit_prelude
= []
| otherwise = [preludeImportDecl]
where
explicit_prelude_import
= notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _) <- import_decls,
unLoc mod == pRELUDE_NAME ]
preludeImportDecl :: LImportDecl RdrName
preludeImportDecl
= L loc $
ImportDecl (L loc pRELUDE_NAME)
Nothing
False
False
Nothing
Nothing
loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")
parseError :: GhcMonad m => SrcSpan -> Message -> m a
parseError span err = throwOneError $ mkPlainErrMsg span err
getOptionsFromFile :: DynFlags
-> FilePath
-> IO [Located String]
getOptionsFromFile dflags filename
= Exception.bracket
(openBinaryFile filename ReadMode)
(hClose)
(\handle -> do
opts <- fmap getOptions' $ lazyGetToks dflags filename handle
seqList opts $ return opts)
blockSize :: Int
blockSize = 1024
lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]
lazyGetToks dflags filename handle = do
buf <- hGetStringBufferBlock handle blockSize
unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
where
loc = mkSrcLoc (mkFastString filename) 1 1
lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
lazyLexBuf handle state eof = do
case unP (lexer return) state of
POk state' t -> do
if atEnd (buffer state') && not eof
then getMore handle state
else case t of
L _ ITeof -> return [t]
_other -> do rest <- lazyLexBuf handle state' eof
return (t : rest)
_ | not eof -> getMore handle state
| otherwise -> return [L (last_loc state) ITeof]
getMore :: Handle -> PState -> IO [Located Token]
getMore handle state = do
nextbuf <- hGetStringBufferBlock handle blockSize
if (len nextbuf == 0) then lazyLexBuf handle state True else do
newbuf <- appendStringBuffers (buffer state) nextbuf
unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False
getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
getToks dflags filename buf = lexAll (pragState dflags buf loc)
where
loc = mkSrcLoc (mkFastString filename) 1 1
lexAll state = case unP (lexer return) state of
POk _ t@(L _ ITeof) -> [t]
POk state' t -> t : lexAll state'
_ -> [L (last_loc state) ITeof]
getOptions :: DynFlags
-> StringBuffer
-> FilePath
-> [Located String]
getOptions dflags buf filename
= getOptions' (getToks dflags filename buf)
getOptions' :: [Located Token]
-> [Located String]
getOptions' toks
= parseToks toks
where
getToken (L _loc tok) = tok
getLoc (L loc _tok) = loc
parseToks (open:close:xs)
| IToptions_prag str <- getToken open
, ITclose_prag <- getToken close
= map (L (getLoc open)) (words str) ++
parseToks xs
parseToks (open:close:xs)
| ITinclude_prag str <- getToken open
, ITclose_prag <- getToken close
= map (L (getLoc open)) ["-#include",removeSpaces str] ++
parseToks xs
parseToks (open:close:xs)
| ITdocOptions str <- getToken open
, ITclose_prag <- getToken close
= map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
++ parseToks xs
parseToks (open:xs)
| ITdocOptionsOld str <- getToken open
= map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
++ parseToks xs
parseToks (open:xs)
| ITlanguage_prag <- getToken open
= parseLanguage xs
parseToks (x:xs)
| ITdocCommentNext _ <- getToken x
= parseToks xs
parseToks _ = []
parseLanguage (L loc (ITconid fs):rest)
= checkExtension (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"
checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
checkProcessArgsResult flags
= when (notNull flags) $
liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
where mkMsg (L loc flag)
= mkPlainErrMsg loc $
(text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
text flag)
checkExtension :: Located FastString -> Located String
checkExtension (L l ext)
= let ext' = unpackFS ext in
if ext' `elem` supportedLanguagesAndExtensions
then L l ("-X"++ext')
else unsupportedExtnError l ext'
languagePragParseError :: SrcSpan -> a
languagePragParseError loc =
throw $ mkSrcErr $ unitBag $
(mkPlainErrMsg loc $
vcat [ text "Cannot parse LANGUAGE pragma"
, text "Expecting comma-separated list of language options,"
, text "each starting with a capital letter"
, nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ])
unsupportedExtnError :: SrcSpan -> String -> a
unsupportedExtnError loc unsup =
throw $ mkSrcErr $ unitBag $
mkPlainErrMsg loc $
text "Unsupported extension: " <> text unsup $$
if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
where suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
optionsErrorMsgs unhandled_flags flags_lines _filename
= (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
where unhandled_flags_lines = [ L l f | f <- unhandled_flags,
L l f' <- flags_lines, f == f' ]
mkMsg (L flagSpan flag) =
ErrUtils.mkPlainErrMsg flagSpan $
text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag