module Language.Haskell.GHC.Simple (
compile, compileWith, compileFold,
module Simple.Types,
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,
module DriverPhases,
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 DriverPhases
import DriverPipeline
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 Data.Binary
import qualified Data.ByteString.Lazy as BS
import Data.IORef
import Control.Monad
import GHC.Paths (libdir)
import System.Directory
import System.FilePath
import System.IO
import System.IO.Unsafe
import Language.Haskell.GHC.Simple.PrimIface as Simple.PrimIface
import Language.Haskell.GHC.Simple.Types as Simple.Types
import Language.Haskell.GHC.Simple.Impl
compile :: (Intermediate a, Binary b)
=> (ModMetadata -> a -> IO b)
-> [String]
-> IO (CompResult [CompiledModule b])
compile = compileWith defaultConfig
compileWith :: (Intermediate a, Binary b)
=> CompConfig
-> (ModMetadata -> a -> IO b)
-> [String]
-> IO (CompResult [CompiledModule b])
compileWith cfg comp = compileFold cfg comp consMod []
consMod :: [CompiledModule a] -> CompiledModule a -> IO [CompiledModule a]
consMod xs x = return (x:xs)
getDynFlagsForConfig :: CompConfig -> IO (DynFlags, [String])
getDynFlagsForConfig cfg = initStaticFlags `seq` do
ws <- newIORef []
runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do
setDFS cfg (discardStaticFlags (cfgGhcFlags cfg)) ws noComp
noComp :: FilePath -> ModSummary -> CgGuts -> CompPipeline ()
noComp _ _ _ = return ()
setDFS :: CompConfig
-> [String]
-> IORef [Warning]
-> (FilePath -> ModSummary -> CgGuts -> CompPipeline ())
-> Ghc (DynFlags, [String])
setDFS cfg flags warns comp = do
dfs <- getSessionDynFlags
(dfs', files2, _dynwarns) <- parseDynamicFlags dfs (map noLoc flags)
let ps = cfgStopPhases cfg
dfs'' = cfgUpdateDynFlags cfg $ dfs' {
log_action = logger (log_action dfs') warns,
hooks = (hooks dfs') {runPhaseHook = Just $ phaseHook ps}
}
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
phaseHook _ p@(HscOut src mod_name result) inp dfs = do
loc <- getLocation src mod_name
setModLocation loc
let next = hscPostBackendPhase dfs src (hscTarget dfs)
case result of
HscRecomp cgguts ms -> do
outfile <- phaseOutputFilename next
comp (ml_hi_file loc) ms cgguts
runPhase p inp dfs
_ ->
runPhase p inp dfs
phaseHook stop (RealPhase p) inp _ | p `elem` stop =
return (RealPhase StopLn, inp)
phaseHook _ p inp dfs =
runPhase p inp dfs
writeModCache :: Binary a => CompConfig -> ModSummary -> a -> IO ()
writeModCache cfg ms m = do
createDirectoryIfMissing True (takeDirectory cachefile)
BS.writeFile cachefile (encode m)
where
cachefile = cacheFileFor cfg (ms_mod_name ms)
readModCache :: Binary a
=> CompConfig
-> ModMetadata
-> [Target]
-> IO (CompiledModule a)
readModCache cfg meta tgts = do
m <- decode `fmap` BS.readFile cachefile
return $ CompiledModule m meta (mmSummary meta `isTarget` tgts)
where
cachefile = cacheFileFor cfg (ms_mod_name (mmSummary meta))
cacheFileFor :: CompConfig -> ModuleName -> FilePath
cacheFileFor cfg name =
maybe "" id (cfgCacheDirectory cfg) </> modfile
where
modfile = moduleNameSlashes name <.> cfgCacheFileExt cfg
compileFold :: (Intermediate a, Binary b)
=> CompConfig
-> (ModMetadata -> a -> IO b)
-> (acc -> CompiledModule b -> IO acc)
-> acc
-> [String]
-> IO (CompResult acc)
compileFold cfg comp f acc files = initStaticFlags `seq` do
warns <- newIORef []
runGhc (maybe (Just libdir) Just (cfgGhcLibDir cfg)) $ do
(_, files2) <- setDFS cfg dfs warns compileToCache
ecode <- genCode cfg f 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
dfs = discardStaticFlags (cfgGhcFlags cfg)
compileToCache hifile ms cgguts = do
source <- prepare ms cgguts
liftIO $ comp (toModMetadata cfg ms) source >>= writeModCache cfg ms
isTarget :: ModSummary -> [Target] -> Bool
isTarget ms = any (`isTargetOf` ms)
isTargetOf :: Target -> ModSummary -> Bool
isTargetOf t ms =
case targetId t of
TargetModule mn -> ms_mod_name ms == mn
TargetFile fn _
| ModLocation (Just f) _ _ <- ms_location ms -> f == fn
_ -> False
initStaticFlags :: [Located String]
initStaticFlags = unsafePerformIO $ fmap fst (parseStaticFlags [])
genCode :: (GhcMonad m, Binary b)
=> CompConfig
-> (a -> CompiledModule b -> IO a)
-> a
-> [String]
-> m (Either [Error] (DynFlags, a))
genCode cfg f acc files = do
dfs <- getSessionDynFlags
eerrs <- handleSourceError (maybeErrors dfs) $ do
ts <- mapM (flip guessTarget Nothing) files
setTargets ts
(loads, mss) <- do
loads <- load LoadAllTargets
mss <- depanal [] False
recomp <- filterM needRecomp mss
if null recomp
then return (loads, mss)
else do
mapM_ (liftIO . removeFile . ml_obj_file . ms_location) recomp
loads' <- load LoadAllTargets
mss' <- depanal [] False
return (loads', mss')
acc' <- liftIO $ foldM (loadCachedMod ts) acc mss
return $ if succeeded loads then Right acc' else Left []
case eerrs of
Left errs -> return $ Left errs
Right acc -> return $ Right (dfs, acc)
where
needRecomp =
liftIO . fmap not . doesFileExist . cacheFileFor cfg . ms_mod_name
loadCachedMod tgts acc ms =
readModCache cfg (toModMetadata cfg ms) tgts >>= f acc
maybeErrors dfs
| cfgUseGhcErrorLogger cfg = \srcerr -> liftIO $ do
let msgs = srcErrorMessages srcerr
printBagOfErrors dfs msgs
return . Left . map (fromErrMsg dfs) $ bagToList msgs
| otherwise =
return . Left . 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