Make sure stdoutGateway is running during findCradle'

This commit is contained in:
Daniel Gröber 2015-09-14 05:40:07 +02:00
parent 64379a7c56
commit 4536ac545d
1 changed files with 13 additions and 19 deletions

View File

@ -26,7 +26,6 @@ module Language.Haskell.GhcMod.Monad (
, runGmlTWith , runGmlTWith
, runGmPkgGhc , runGmPkgGhc
, withGhcModEnv , withGhcModEnv
, withGhcModEnv'
, module Language.Haskell.GhcMod.Monad.Types , module Language.Haskell.GhcMod.Monad.Types
) where ) where
@ -52,28 +51,23 @@ import Exception (ExceptionMonad(..))
import System.Directory import System.Directory
import Prelude import Prelude
withCradle :: (IOish m, GmOut m) => FilePath -> (Cradle -> m a) -> m a
withCradle cradledir f =
gbracket (findCradle' cradledir) (liftIO . cleanupCradle) f
withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a
withGhcModEnv dir opts f = withGhcModEnv dir opts f =
withCradle dir (withGhcModEnv' opts f) withStdoutGateway $
withCradle $ \crdl ->
withGhcModEnv' :: (IOish m, GmOut m) => Options -> (GhcModEnv -> m a) -> Cradle -> m a withCradleRootDir crdl $
withGhcModEnv' opts f crdl = do f $ GhcModEnv opts crdl
olddir <- liftIO getCurrentDirectory
gbracket_ setup (teardown olddir) (f $ GhcModEnv opts crdl)
where where
setup = do withStdoutGateway a = do
c <- gmoChan <$> gmoAsk c <- gmoChan <$> gmoAsk
liftIO $ do gbracket_ (liftIO $ forkIO $ stdoutGateway c) (liftIO . killThread) a
setCurrentDirectory $ cradleRootDir crdl
forkIO $ stdoutGateway c
teardown olddir tid = liftIO $ do withCradle =
setCurrentDirectory olddir gbracket (findCradle' dir) (liftIO . cleanupCradle)
killThread tid
withCradleRootDir (cradleRootDir -> projdir) =
gbracket_ (liftIO $ setCurrentDirectory projdir >> getCurrentDirectory)
(liftIO . setCurrentDirectory)
gbracket_ ma mb mc = gbracket ma mb (const mc) gbracket_ ma mb mc = gbracket ma mb (const mc)