{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} 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 PprColour import qualified Util -- import Packages import Linker #if __GLASGOW_HASKELL__ < 800 import Control.Monad #endif import Control.Monad.IO.Class import Data.IORef import Data.Time import Halive.FindPackageDBs import Control.Concurrent import System.Signal import Data.Dynamic import System.Directory import System.FilePath import Data.Time.Clock.POSIX import qualified Data.Text as Text data FixDebounce = DebounceFix | NoDebounceFix deriving Eq data CompliationMode = Interpreted | Compiled deriving Eq data KeepLibsInMemory = Always | Opportunistic data GHCSessionConfig = GHCSessionConfig { gscFixDebounce :: FixDebounce , gscImportPaths :: [FilePath] , gscPackageDBs :: [FilePath] , gscLibDir :: FilePath #if __GLASGOW_HASKELL__ >= 800 , gscLanguageExtensions :: [Extension] , gscNoLanguageExtensions :: [Extension] #else , gscLanguageExtensions :: [ExtensionFlag] , gscNoLanguageExtensions :: [ExtensionFlag] #endif , gscCompilationMode :: CompliationMode , gscStartupFile :: Maybe (FilePath, String) -- ^ Allow API users to block until a given file is compiled, -- to work around a bug where the GHC API crashes while -- loading libraries if the main thread is doing work -- (possibly due to accessing said libraries in some way) , gscVerbosity :: Int , gscMainThreadID :: Maybe ThreadId , gscKeepLibsInMemory :: KeepLibsInMemory -- ^ Chooses between keeping the GHC session alive continuously -- (which uses a lot of memory but makes compilation fast) -- or disposing of it between compilations -- (which saves memory but slows compilation) -- or keeping it around for sequences of compilations -- (which lies in-between these) , gscUseColor :: Bool } defaultGHCSessionConfig :: GHCSessionConfig defaultGHCSessionConfig = GHCSessionConfig { gscFixDebounce = DebounceFix , gscImportPaths = [] , gscPackageDBs = [] , gscLanguageExtensions = [] , gscNoLanguageExtensions = [] , gscLibDir = libdir , gscCompilationMode = Interpreted , gscStartupFile = Nothing , gscVerbosity = 0 , gscMainThreadID = Nothing , gscKeepLibsInMemory = Always , gscUseColor = False } -- Starts up a GHC session and then runs the given action within it withGHCSession :: ThreadId -> GHCSessionConfig -> Ghc a -> IO a withGHCSession mainThreadID GHCSessionConfig{..} action = do -- Work around https://ghc.haskell.org/trac/ghc/ticket/4162 let restoreControlC f = do liftIO $ installHandler sigINT (\_signal -> killThread mainThreadID) f -- defaultErrorHandler defaultFatalMessager defaultFlushOut $ runGhc (Just libdir) $ do runGhc (Just gscLibDir) . restoreControlC $ do -- initialFlags <- getSessionDynFlags -- (newFlags, leftovers, warnings) <- parseDynamicFlagsCmdLine initialFlags [noLoc "-prof"] -- setSessionDynFlags newFlags -- liftIO $ print (compilerInfo newFlags) packageIDs <- getSessionDynFlags >>= updateDynFlagsWithGlobalDB -- If this is a stack project, add its package DBs >>= updateDynFlagsWithStackDB -- If there's a sandbox, add its package DB >>= updateDynFlagsWithCabalSandbox -- Add passed-in package DBs >>= (pure . addExtraPkgConfs gscPackageDBs) -- Make sure we're configured for live-reload >>= (\d -> pure d { hscTarget = if gscCompilationMode == Compiled then HscAsm else HscInterpreted , optLevel = if gscCompilationMode == Compiled then 1 else 0 , ghcLink = LinkInMemory , ghcMode = CompManager , importPaths = gscImportPaths , objectDir = Just ".halive" , hiDir = Just ".halive" , stubDir = Just ".halive" , dumpDir = Just ".halive" , verbosity = gscVerbosity , useColor = if gscUseColor then Util.Always else Util.Never , canUseColor = gscUseColor , colScheme = defaultScheme }) >>= (pure . (`gopt_set` Opt_DiagnosticsShowCaret)) -- turn off the GHCi sandbox -- since it breaks OpenGL/GUI usage >>= (pure . (`gopt_unset` Opt_GhciSandbox)) -- Allows us to work in dynamic executables -- >>= (pure . (if dynamicGhc then addWay' WayDyn else id)) -- >>= (pure . (addWay' WayProf)) -- >>= (pure . (if rtsIsProfiled then addWay' WayProf else id)) -- >>= (pure . (addWay' WayDyn)) -- GHC seems to try to "debounce" compilations within -- about a half second (i.e., it won't recompile) -- This fixes that, but probably isn't quite what we want -- since it will cause extra files to be recompiled... >>= (pure . (if gscFixDebounce == DebounceFix then (`gopt_set` Opt_ForceRecomp) else id)) >>= (pure . flip (foldl xopt_unset) gscNoLanguageExtensions . flip (foldl xopt_set) gscLanguageExtensions) -- We must call setSessionDynFlags before calling initPackages or any other GHC API >>= setSessionDynFlags -- Initialize the package database and dynamic linker. -- Explicitly calling these avoids crashes on some of my machines. #if __GLASGOW_HASKELL__ >= 800 -- (dflags,_pkgs) <- liftIO . initPackages =<< getSessionDynFlags -- setSessionDynFlags dflags getSession >>= \hscEnv -> liftIO $ linkPackages hscEnv packageIDs liftIO . initDynLinker =<< getSession #else getSessionDynFlags >>= \dflags -> liftIO $ linkPackages dflags packageIDs liftIO . initDynLinker =<< getSessionDynFlags #endif result <- action -- Unload libraries to keep from leaking memory & overloading the GC getSession >>= \hscEnv -> liftIO (unload hscEnv []) return result newtype CompiledValue = CompiledValue Dynamic deriving Show getCompiledValue :: Typeable a => CompiledValue -> Maybe a getCompiledValue (CompiledValue r) = fromDynamic r fileContentsStringToBuffer :: (MonadIO m) => String -> m (StringBuffer, UTCTime) fileContentsStringToBuffer fileContents = do now <- liftIO getCurrentTime return (stringToStringBuffer fileContents, now) createTempFile :: MonadIO m => m FilePath createTempFile = liftIO $ do tempDir <- getTemporaryDirectory now <- show . diffTimeToPicoseconds . realToFrac <$> getPOSIXTime let tempFile = tempDir "halive_" ++ now <.> "hs" writeFile tempFile "" return tempFile -- | Takes a filename, optionally its contents, and a list of expressions. -- Returns a list of errors or a list of Dynamic compiled values recompileExpressionsInFile :: FilePath -> Maybe String -> [String] -> Ghc (Either String [CompiledValue]) recompileExpressionsInFile fileName mFileContents expressions = catchExceptions . handleSourceError (fmap Left . gatherErrors) $ do -- Set up an error accumulator errorsRef <- liftIO (newIORef "") _ <- getSessionDynFlags >>= \dflags -> setSessionDynFlags dflags { log_action = logHandler errorsRef } mFileContentsBuffer <- mapM fileContentsStringToBuffer mFileContents -- Set the target (tempFileName, target) <- case fileName of -- We'd like to just use a Module name for the target, -- but load/depanal fails with "Foo is a package module" -- We use a blank temp file as a workaround. "" -> do tempFileName <- createTempFile (tempFileName,) <$> guessTarget' tempFileName other -> ("",) <$> guessTarget' other -- logIO "Setting targets..." setTargets [target { targetContents = mFileContentsBuffer }] -- Reload the main target -- logIO "Loading..." loadSuccess <- load LoadAllTargets if succeeded loadSuccess then do -- logIO "Analyzing deps..." -- Get the dependencies of the main target (and update the session with them) graph <- depanal [] False #if __GLASGOW_HASKELL__ >= 804 let modSummaries = mgModSummaries graph #else let modSummaries = graph #endif -- Load the dependencies of the main target setContext (IIDecl . simpleImportDecl . ms_mod_name <$> modSummaries) -- Compile the expressions and return the results results <- mapM dynCompileExpr expressions return (Right (CompiledValue <$> results)) else do -- Extract the errors from the accumulator errors <- liftIO (readIORef errorsRef) -- Strip out the temp file name when using anonymous code let cleanErrors = if null tempFileName then errors else Text.unpack $ Text.replace (Text.pack tempFileName) "" (Text.pack errors) return (Left cleanErrors) -- Prepend a '*' to prevent GHC from trying to load from any previously compiled object files -- see http://stackoverflow.com/questions/12790341/haskell-ghc-dynamic-compliation-only-works-on-first-compile guessTarget' :: GhcMonad m => String -> m Target guessTarget' fileName = guessTarget ('*':fileName) Nothing 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)) ) -- Adapted from -- https://hackage.haskell.org/package/ghc-8.2.1/docs/src/DynFlags.html#defaultLogAction logHandler :: IORef String -> LogAction logHandler errorIORef dflags reason severity srcSpan style msg = case severity of SevOutput -> printOut msg style SevDump -> printOut (msg $$ blankLine) style SevInteractive -> putStrSDoc msg style SevInfo -> printErrs msg style SevFatal -> printErrs msg style _ -> do -- otherwise (i.e. SevError or SevWarning) caretDiagnostic <- if gopt Opt_DiagnosticsShowCaret dflags then getCaretDiagnostic severity srcSpan else pure empty writeToErrorIORef (message $+$ caretDiagnostic) (setStyleColoured True style) -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of -- each unicode char. where printOut = writeToErrorIORef printErrs = writeToErrorIORef putStrSDoc = writeToErrorIORef -- Pretty print the warning flag, if any (#10752) message = mkLocMessageAnn Nothing severity srcSpan msg writeToErrorIORef message style = modifyIORef' errorIORef (++ ('\n':renderWithStyle dflags message style)) -- 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 -- caretDiagnostic <- getCaretDiagnostic dflags srcSpan -- let cntx = initSDocContext dflags style -- locMsg = mkLocMessage severity srcSpan msg -- messageWithLocation = show (runSDoc locMsg cntx) -- messageOther = show (runSDoc msg cntx) -- renderWithStyle dflags (msg $+$ caretDiagnostic) -- (setStyleColoured True style) -- case severity of -- SevError -> modifyIORef' ref (++ ('\n':messageWithLocation)) -- SevFatal -> modifyIORef' ref (++ ('\n':messageWithLocation)) -- SevWarning -> modifyIORef' ref (++ ('\n':messageWithLocation)) -- _ -> do -- putStr messageOther -- return () -- ignore the rest -- A helper from interactive-diagrams to print out GHC API values, -- useful while debugging the API. -- | Outputs any value that can be pretty-printed using the default style output :: (GhcMonad m, Outputable a) => a -> m () output a = do dfs <- getSessionDynFlags let style = defaultUserStyle dfs let cntx = initSDocContext dfs style liftIO $ print $ runSDoc (ppr a) cntx -- NOTE: handleSourceError (which calls gatherErrors above) -- doesn't actually seem to do anything, so we use -- the IORef + log_action solution instead. -- The API docs claim 'load' should -- throw SourceErrors but it doesn't afaict. gatherErrors :: GhcMonad m => SourceError -> m String gatherErrors sourceError = do printException sourceError dflags <- getSessionDynFlags let style = mkUserStyle dflags neverQualify AllTheWay errorSDocs = pprErrMsgBagWithLoc (srcErrorMessages sourceError) errorStrings = map (showSDocForUser dflags neverQualify) errorSDocs return (concat errorStrings) --pkgConfRefToString = \case -- GlobalPkgConf -> "GlobalPkgConf" -- UserPkgConf -> "UserPkgConf" -- PkgConfFile file -> "PkgConfFile " ++ show file --extraPkgConfsToString dflags = show $ map pkgConfRefToString $ extraPkgConfs dflags $ [] logIO :: MonadIO m => String -> m () logIO = liftIO . putStrLn