module Halive.SubHalive (
module Halive.SubHalive
#if __GLASGOW_HASKELL__ >= 800
, module GHC.LanguageExtensions
#else
, ExtensionFlag(..)
#endif
) where
import GHC
#if __GLASGOW_HASKELL__ >= 800
import GHC.LanguageExtensions
#else
import Module
#endif
import DynFlags
import Exception
import ErrUtils
import HscTypes
import GHC.Paths
import Outputable
import StringBuffer
import Linker
import Control.Monad
import Control.Monad.IO.Class
import Data.IORef
import Data.Time
import Halive.FindPackageDBs
import Control.Concurrent
import System.Signal
import Data.Dynamic
data FixDebounce = DebounceFix | NoDebounceFix deriving Eq
data CompliationMode = Interpreted | Compiled deriving Eq
data GHCSessionConfig = GHCSessionConfig
{ gscFixDebounce :: FixDebounce
, gscImportPaths :: [FilePath]
, gscPackageDBs :: [FilePath]
, gscLibDir :: FilePath
#if __GLASGOW_HASKELL__ >= 800
, gscLanguageExtensions :: [Extension]
#else
, gscLanguageExtensions :: [ExtensionFlag]
#endif
, gscCompilationMode :: CompliationMode
, gscStartupFile :: Maybe (FilePath, String)
, gscVerbosity :: Int
}
defaultGHCSessionConfig :: GHCSessionConfig
defaultGHCSessionConfig = GHCSessionConfig
{ gscFixDebounce = DebounceFix
, gscImportPaths = []
, gscPackageDBs = []
, gscLanguageExtensions = []
, gscLibDir = libdir
, gscCompilationMode = Interpreted
, gscStartupFile = Nothing
, gscVerbosity = 0
}
logIO :: MonadIO m => String -> m ()
logIO = liftIO . putStrLn
withGHCSession :: ThreadId -> GHCSessionConfig -> Ghc a -> IO a
withGHCSession mainThreadID GHCSessionConfig{..} action = do
let restoreControlC f = do
liftIO $ installHandler sigINT (\_signal -> killThread mainThreadID)
f
runGhc (Just gscLibDir) . restoreControlC $ do
dflags0 <- getSessionDynFlags
let dflags1 = addExtraPkgConfs dflags0 gscPackageDBs
dflags2 <- updateDynFlagsWithCabalSandbox dflags1
dflags3 <- updateDynFlagsWithStackDB dflags2
let dflags4 = dflags3 { hscTarget = if gscCompilationMode == Compiled then HscAsm else HscInterpreted
, optLevel = if gscCompilationMode == Compiled then 2 else 0
, ghcLink = LinkInMemory
, ghcMode = CompManager
, importPaths = gscImportPaths
, objectDir = Just ".halive"
, hiDir = Just ".halive"
, stubDir = Just ".halive"
, dumpDir = Just ".halive"
, verbosity = gscVerbosity
}
`gopt_unset` Opt_GhciSandbox
dflags5 = if gscFixDebounce == DebounceFix
then dflags4 `gopt_set` Opt_ForceRecomp
else dflags4
dflags6 = foldl xopt_set dflags5 gscLanguageExtensions
packageIDs <- setSessionDynFlags dflags6
let finalPackageIDs = packageIDs
#if __GLASGOW_HASKELL__ >= 800
hscEnv1 <- getSession
liftIO $ linkPackages hscEnv1 finalPackageIDs
hscEnv2 <- getSession
liftIO (initDynLinker hscEnv2)
#else
dflags7 <- getSessionDynFlags
liftIO $ linkPackages dflags7 finalPackageIDs
dflags8 <- getSessionDynFlags
liftIO (initDynLinker dflags8)
#endif
action
gatherErrors :: GhcMonad m => SourceError -> m [String]
gatherErrors sourceError = do
printException sourceError
dflags <- getSessionDynFlags
let errorSDocs = pprErrMsgBagWithLoc (srcErrorMessages sourceError)
errorStrings = map (showSDoc dflags) errorSDocs
return errorStrings
newtype CompiledValue = CompiledValue Dynamic deriving Show
getCompiledValue :: Typeable a => CompiledValue -> Maybe a
getCompiledValue (CompiledValue r) = fromDynamic r
fileContentsStringToBuffer :: (MonadIO m) => Maybe String -> m (Maybe (StringBuffer, UTCTime))
fileContentsStringToBuffer mFileContents = forM mFileContents $ \fileContents -> do
now <- liftIO getCurrentTime
return (stringToStringBuffer fileContents, now)
recompileExpressionInFile :: FilePath -> Maybe String -> String -> Ghc (Either [String] CompiledValue)
recompileExpressionInFile fileName mFileContents expression =
catchExceptions . handleSourceError (fmap Left . gatherErrors) $ do
target <- guessTarget ('*':fileName) Nothing
mFileContentsBuffer <- fileContentsStringToBuffer mFileContents
setTargets [target { targetContents = mFileContentsBuffer }]
errorsRef <- liftIO (newIORef "")
dflags <- getSessionDynFlags
_ <- setSessionDynFlags dflags { log_action = logHandler errorsRef }
graph <- depanal [] False
loadSuccess <- load LoadAllTargets
if failed loadSuccess
then do
errors <- liftIO (readIORef errorsRef)
return (Left [errors])
else do
forM_ graph (typecheckModule <=< parseModule)
setContext (IIDecl . simpleImportDecl . ms_mod_name <$> graph)
result <- dynCompileExpr expression
return (Right (CompiledValue result))
catchExceptions :: ExceptionMonad m => m (Either [String] a) -> m (Either [String] a)
catchExceptions a = gcatch a
(\(_x :: SomeException) -> do
liftIO (putStrLn ("Caught exception during recompileExpressionInFile: " ++ show _x))
return (Left [show _x]))
output :: (GhcMonad m, Outputable a) => a -> m ()
output a = do
dfs <- getSessionDynFlags
let style = defaultUserStyle
let cntx = initSDocContext dfs style
liftIO $ print $ runSDoc (ppr a) cntx
logHandler :: IORef String -> LogAction
#if __GLASGOW_HASKELL__ >= 800
logHandler ref dflags _warnReason severity srcSpan style msg =
#else
logHandler ref dflags severity srcSpan style msg =
#endif
case severity of
SevError -> modifyIORef' ref (++ ('\n':messageWithLocation))
SevFatal -> modifyIORef' ref (++ ('\n':messageWithLocation))
SevWarning -> modifyIORef' ref (++ ('\n':messageWithLocation))
_ -> do
putStr messageOther
return ()
where cntx = initSDocContext dflags style
locMsg = mkLocMessage severity srcSpan msg
messageWithLocation = show (runSDoc locMsg cntx)
messageOther = show (runSDoc msg cntx)