module HsDev.Tools.Ghc.Worker (
ghcWorker, ghciWorker,
ghcRun,
withFlags, modifyFlags, addCmdOpts, setCmdOpts,
importModules, preludeModules,
evaluate,
clearTargets, makeTarget, loadTargets,
listPackages, spanRegion,
withCurrentDirectory,
logToChan, logToNull,
Ghc,
module Control.Concurrent.Worker
) where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Except
import Data.Dynamic
import Data.Maybe
import Data.Time.Clock (getCurrentTime)
import Data.Version (showVersion)
import Packages
import StringBuffer
import System.Directory (getCurrentDirectory, setCurrentDirectory)
import Text.Read
import GHC hiding (Warning, Module, moduleName)
import GHC.Paths
import Outputable
import qualified ErrUtils as E
import FastString (unpackFS)
import Control.Concurrent.FiniteChan
import Control.Concurrent.Worker
import System.Directory.Paths
import HsDev.Symbols.Location (Position(..), Region(..), region, ModulePackage, ModuleLocation(..))
import HsDev.Tools.Types
ghcWorker :: [String] -> Ghc () -> IO (Worker Ghc)
ghcWorker opts initialize = startWorker (runGhc (Just libdir)) ghcInit id where
ghcInit f = ghcRun opts (initialize >> f)
ghciWorker :: IO (Worker Ghc)
ghciWorker = ghcWorker [] (importModules preludeModules)
ghcRun :: [String] -> Ghc a -> Ghc a
ghcRun opts f = do
fs <- getSessionDynFlags
defaultCleanupHandler fs $ do
(fs', _, _) <- parseDynamicFlags fs (map noLoc opts)
let fs'' = fs' {
ghcMode = CompManager,
ghcLink = NoLink,
hscTarget = HscNothing }
void $ setSessionDynFlags fs''
f
withFlags :: Ghc a -> Ghc a
withFlags = gbracket getSessionDynFlags (\fs -> setSessionDynFlags fs >> return ()) . const
modifyFlags :: (DynFlags -> DynFlags) -> Ghc ()
modifyFlags f = do
fs <- getSessionDynFlags
let
fs' = f fs
_ <- setSessionDynFlags fs'
_ <- liftIO $ initPackages fs'
return ()
addCmdOpts :: [String] -> Ghc ()
addCmdOpts opts = do
fs <- getSessionDynFlags
(fs', _, _) <- parseDynamicFlags fs (map noLoc opts)
let fs'' = fs' {
ghcMode = CompManager,
ghcLink = NoLink,
hscTarget = HscNothing }
void $ setSessionDynFlags fs''
setCmdOpts :: [String] -> Ghc ()
setCmdOpts opts = do
initGhcMonad (Just libdir)
addCmdOpts opts
modifyFlags (\fs -> fs { log_action = logToNull })
importModules :: [String] -> Ghc ()
importModules mods = mapM parseImportDecl ["import " ++ m | m <- mods] >>= setContext . map IIDecl
preludeModules :: [String]
preludeModules = ["Prelude", "Data.List", "Control.Monad", "HsDev.Tools.Ghc.Prelude"]
evaluate :: String -> Ghc String
evaluate expr = liftM fromDynamic (dynCompileExpr $ "show (" ++ expr ++ ")") >>=
maybe (fail "evaluate fail") return
clearTargets :: Ghc ()
clearTargets = loadTargets []
makeTarget :: String -> Maybe String -> Ghc Target
makeTarget name Nothing = guessTarget name Nothing
makeTarget name (Just cts) = do
t <- guessTarget name Nothing
tm <- liftIO getCurrentTime
return t { targetContents = Just (stringToStringBuffer cts, tm) }
loadTargets :: [Target] -> Ghc ()
loadTargets ts = setTargets ts >> load LoadAllTargets >> return ()
listPackages :: Ghc [ModulePackage]
listPackages = liftM (mapMaybe readPackage . fromMaybe [] . pkgDatabase) getSessionDynFlags
readPackage :: PackageConfig -> Maybe ModulePackage
readPackage pc = readMaybe $ packageNameString pc ++ "-" ++ showVersion (packageVersion pc)
spanRegion :: SrcSpan -> Region
spanRegion (RealSrcSpan s) = Position (srcSpanStartLine s) (srcSpanStartCol s) `region` Position (srcSpanEndLine s) (srcSpanEndCol s)
spanRegion _ = Position 0 0 `region` Position 0 0
withCurrentDirectory :: FilePath -> Ghc a -> Ghc a
withCurrentDirectory dir act = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $
const (liftIO (setCurrentDirectory dir) >> act)
logToChan :: Chan (Note OutputMessage) -> DynFlags -> E.Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
logToChan ch fs sev src _ msg
| Just sev' <- checkSev sev = do
src' <- canonicalize srcMod
putChan ch $ Note {
_noteSource = src',
_noteRegion = spanRegion src,
_noteLevel = Just sev',
_note = OutputMessage {
_message = showSDoc fs msg,
_messageSuggestion = Nothing } }
| otherwise = return ()
where
checkSev SevWarning = Just Warning
checkSev SevError = Just Error
checkSev SevFatal = Just Error
checkSev _ = Nothing
srcMod = case src of
RealSrcSpan s' -> FileModule (unpackFS $ srcSpanFile s') Nothing
_ -> ModuleSource Nothing
logToNull :: DynFlags -> E.Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
logToNull _ _ _ _ _ = return ()
instance MonadThrow Ghc where
throwM = liftIO . throwM
instance MonadCatch Ghc where
catch = gcatch