module Language.Haskell.GHC.Simple.Impl (
Compile (..),
Ghc, StgModule, PkgKey,
liftIO,
toSimplifiedStg,
toSimplifiedCore,
toModGuts,
simplify,
prepare, toStgBindings,
toCompiledModule,
modulePkgKey, pkgKeyString
) where
import BinIface
import GHC hiding (Warning)
import GhcMonad (liftIO)
import HscMain
import HscTypes
import TidyPgm
import CorePrep
import StgSyn
import CoreSyn
import CoreToStg
import SimplStg
#if __GLASGOW_HASKELL__ < 710
import qualified Module as M (modulePackageId, packageIdString, PackageId)
#else
import qualified Module as M (modulePackageKey, packageKeyString, PackageKey)
#endif
import Control.Monad
import Data.IORef
import System.FilePath (takeDirectory)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Language.Haskell.GHC.Simple.Types
type StgModule = CompiledModule [StgBinding]
instance Compile [StgBinding] where
toCode = toSimplifiedStg
instance Compile CgGuts where
toCode = toSimplifiedCore
instance Compile ModGuts where
toCode = toModGuts
modulePkgKey :: Module -> PkgKey
pkgKeyString :: PkgKey -> String
#if __GLASGOW_HASKELL__ < 710
type PkgKey = M.PackageId
modulePkgKey = M.modulePackageId
pkgKeyString = M.packageIdString
#else
type PkgKey = M.PackageKey
modulePkgKey = M.modulePackageKey
pkgKeyString = M.packageKeyString
#endif
toCompiledModule :: GhcMonad m
=> CompConfig a
-> (ModSummary -> m a)
-> ModSummary
-> m (CompiledModule a)
toCompiledModule cfg comp ms = do
code <- comp ms
ts <- getTargets
dfs <- getSessionDynFlags
iface <- getModIface dfs
let hifile = ml_hi_file $ ms_location ms
when (cfgAlwaysCreateHiFiles cfg) . liftIO $ do
exists <- doesFileExist hifile
unless exists $ do
createDirectoryIfMissing True (takeDirectory hifile)
writeBinIface dfs hifile iface
return $ CompiledModule {
modSummary = ms,
modName = moduleNameString $ ms_mod_name ms,
modPackageKey = pkgKeyString . modulePkgKey $ ms_mod ms,
modIsTarget = any (`isTargetOf` ms) ts,
modSourceIsHsBoot = ms_hsc_src ms == HsBootFile,
modSourceFile = ml_hs_file $ ms_location ms,
modInterface = iface,
modInterfaceFile = hifile,
modCompiledModule = code
}
where
getModIface dfs = do
env <- getSession
pkgIfaceTbl <- eps_PIT `fmap` liftIO (readIORef (hsc_EPS env))
let homePkgTbl = hsc_HPT env
case lookupIfaceByModule dfs homePkgTbl pkgIfaceTbl (ms_mod ms) of
Just mi -> return mi
_ -> error "Module interface does not exist!"
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
toSimplifiedStg :: GhcMonad m => ModSummary -> m [StgBinding]
toSimplifiedStg ms = do
dfs <- getSessionDynFlags
toSimplifiedCore ms >>= prepare dfs ms >>= toStgBindings dfs ms
toSimplifiedCore :: GhcMonad m => ModSummary -> m CgGuts
toSimplifiedCore = toModGuts >=> simplify
toModGuts :: GhcMonad m => ModSummary -> m ModGuts
toModGuts =
parseModule >=> typecheckModule >=> desugarModule >=> return . coreModule
simplify :: GhcMonad m => ModGuts -> m CgGuts
simplify mg = do
env <- getSession
liftIO $ hscSimplify env mg >>= tidyProgram env >>= return . fst
prepare :: GhcMonad m => DynFlags -> ModSummary -> CgGuts -> m CoreProgram
prepare dfs _ms p = do
env <- getSession
#if __GLASGOW_HASKELL__ < 710
liftIO $ corePrepPgm dfs env (cg_binds p) (cg_tycons p)
#else
liftIO $ corePrepPgm env (ms_location _ms) (cg_binds p) (cg_tycons p)
#endif
toStgBindings :: GhcMonad m
=> DynFlags -> ModSummary -> CoreProgram -> m [StgBinding]
toStgBindings dfs ms p = liftIO $ do
stg <- coreToStg dfs (ms_mod ms) p
fst `fmap` stg2stg dfs (ms_mod ms) stg