module Language.Haskell.GHC.Simple (
compile, compileWith, compileFold,
module Simple.Types,
StgModule,
getDynFlagsForConfig,
module CoreSyn, module StgSyn, module Module,
module Id, module IdInfo, module Var, module Literal, module DataCon,
module OccName, module Name,
module Type, module TysPrim, module TyCon,
module ForeignCall, module PrimOp,
module DynFlags, module SrcLoc,
ModSummary (..), ModGuts (..),
PkgKey,
pkgKeyString, modulePkgKey
) where
import GHC hiding (Warning)
import GhcMonad (liftIO)
import DynFlags
import HscTypes
import ErrUtils
import Bag
import SrcLoc
import Outputable
import Hooks
import StaticFlags (discardStaticFlags)
import StgSyn
import CoreSyn
import Name hiding (varName)
import Type
import TysPrim
import TyCon
import Literal
import Var hiding (setIdExported, setIdNotExported, lazySetIdInfo)
import Id
import IdInfo
import OccName hiding (varName)
import DataCon
import ForeignCall
import PrimOp
import Module
import GHC.Paths (libdir)
import Data.IORef
import Control.Monad
import Language.Haskell.GHC.Simple.PrimIface as Simple.PrimIface
import Language.Haskell.GHC.Simple.Types as Simple.Types
import Language.Haskell.GHC.Simple.Impl
import System.IO.Unsafe
compile :: Compile a
=> [String]
-> IO (CompResult [CompiledModule a])
compile = compileWith defaultConfig
compileWith :: Compile a
=> CompConfig a
-> [String]
-> IO (CompResult [CompiledModule a])
compileWith cfg = compileFold (cfg {cfgGhcPipeline = toCode}) consMod []
consMod :: [CompiledModule a] -> CompiledModule a -> IO [CompiledModule a]
consMod xs x = return (x:xs)
getDynFlagsForConfig :: CompConfig a -> IO (DynFlags, [String])
getDynFlagsForConfig cfg = initStaticFlags `seq` do
ws <- newIORef []
runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do
setDFS cfg (discardStaticFlags (cfgGhcFlags cfg)) ws
setDFS :: CompConfig a
-> [String]
-> IORef [Warning]
-> Ghc (DynFlags, [String])
setDFS cfg flags warns = do
dfs <- getSessionDynFlags
(dfs', files2, _dynwarns) <- parseDynamicFlags dfs (map noLoc flags)
let dfs'' = cfgUpdateDynFlags cfg $ dfs' {
log_action = logger (log_action dfs') warns
}
case cfgCustomPrimIface cfg of
Just (nfo, strs) -> setPrimIface dfs'' nfo strs
_ -> void $ setSessionDynFlags dfs''
finaldfs <- getSessionDynFlags
return (finaldfs, map unLoc files2)
where
logger deflog warns dfs severity srcspan style msg
| cfgUseGhcErrorLogger cfg = do
logger' deflog warns dfs severity srcspan style msg
case severity of
SevWarning -> deflog dfs severity srcspan style msg
SevError -> deflog dfs severity srcspan style msg
_ -> return ()
| otherwise = do
logger' deflog warns dfs severity srcspan style msg
logger' _ w dfs SevWarning srcspan _style msg = do
liftIO $ atomicModifyIORef' w $ \ws ->
(Warning srcspan (showSDoc dfs msg) : ws, ())
logger' _ _ _ SevError _ _ _ = do
return ()
logger' output _ dfs sev srcspan style msg = do
output dfs sev srcspan style msg
setPrimIface dfs nfo strs = do
void $ setSessionDynFlags dfs {
hooks = (hooks dfs) {ghcPrimIfaceHook = Just $ primIface nfo strs}
}
getSession >>= liftIO . fixPrimopTypes nfo strs
compileFold :: CompConfig b
-> (a -> CompiledModule b -> IO a)
-> a
-> [String]
-> IO (CompResult a)
compileFold cfg comp acc files = initStaticFlags `seq` do
warns <- newIORef []
runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do
(_, files2) <- setDFS cfg (discardStaticFlags (cfgGhcFlags cfg)) warns
ecode <- genCode cfg ghcPipeline comp acc (files ++ files2)
ws <- liftIO $ readIORef warns
case ecode of
Right (finaldfs, code) ->
return Success {
compResult = code,
compWarnings = ws,
compDynFlags = finaldfs
}
Left es ->
return Failure {
compErrors = es,
compWarnings = ws
}
where
ghcPipeline = toCompiledModule $ cfgGhcPipeline cfg
initStaticFlags :: [Located String]
initStaticFlags = unsafePerformIO $ fmap fst (parseStaticFlags [])
genCode :: GhcMonad m
=> CompConfig t
-> (ModSummary -> m a)
-> (b -> a -> IO b)
-> b
-> [String]
-> m (Either [Error] (DynFlags, b))
genCode cfg comp usercomp acc files = do
dfs <- getSessionDynFlags
merrs <- handleSourceError (maybeErrors dfs) $ do
ts <- mapM (flip guessTarget Nothing) files
setTargets ts
loads <- load LoadAllTargets
return $ if succeeded loads then Nothing else Just []
case merrs of
Just errs -> return $ Left errs
_ -> do
mss <- depanal [] False
code <- foldM (\a x -> comp (noLog x) >>= liftIO . usercomp a) acc mss
return $ Right (dfs, code)
where
noLog m =
m {ms_hspp_opts = (ms_hspp_opts m) {log_action = \_ _ _ _ _ -> return ()}}
maybeErrors dfs
| cfgUseGhcErrorLogger cfg = \srcerr -> liftIO $ do
let msgs = srcErrorMessages srcerr
printBagOfErrors dfs msgs
return . Just . map (fromErrMsg dfs) $ bagToList msgs
| otherwise =
return . Just . map (fromErrMsg dfs) . bagToList . srcErrorMessages
fromErrMsg :: DynFlags -> ErrMsg -> Error
fromErrMsg dfs e = Error {
errorSpan = errMsgSpan e,
errorMessage = showSDocForUser dfs ctx (errMsgShortDoc e),
errorExtraInfo = showSDocForUser dfs ctx (errMsgExtraInfo e)
}
where
ctx = errMsgContext e