Don't mess with cwd, causes too many race conditions

I would just fork() but we have to support WinDOS, gah.
This commit is contained in:
Daniel Gröber 2015-09-14 09:42:45 +02:00
parent 6488f1070d
commit 56902bfe2d
6 changed files with 81 additions and 63 deletions

View File

@ -8,7 +8,6 @@ import qualified Data.Set as Set
import Data.Char
import Data.List.Split
import Text.PrettyPrint
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Internal
@ -16,6 +15,7 @@ import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Pretty
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Cradle
----------------------------------------------------------------
@ -138,5 +138,5 @@ mapDoc kd ad m = vcat $
----------------------------------------------------------------
-- | Obtaining root information.
rootInfo :: IOish m => GhcModT m String
rootInfo = convert' =<< cradleRootDir <$> cradle
rootInfo :: (IOish m, GmOut m) => m String
rootInfo = (++"\n") . cradleRootDir <$> findCradle

View File

@ -33,7 +33,7 @@ module Language.Haskell.GhcMod.Error (
, module Control.Exception
) where
import Control.Arrow
import Control.Arrow hiding ((<+>))
import Control.Exception
import Control.Monad.Error hiding (MonadIO, liftIO)
import qualified Data.Set as Set
@ -143,6 +143,11 @@ gmeDoc e = case e of
GMEStackBootrap msg ->
(text $ "Boostrapping stack project failed")
<+>: text msg
GMEWrongWorkingDirectory projdir cdir ->
(text $ "You must run ghc-mod in the project directory as returned by `ghc-mod root`.")
<+> text "Currently in:" <+> showDoc cdir
<> text "but should be in" <+> showDoc projdir
<> text "."
ghcExceptionDoc :: GhcException -> Doc
ghcExceptionDoc e@(CmdLineError _) =

View File

@ -17,9 +17,9 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Monad (
runGmOutT
, runGmOutT'
, runGhcModT
, runGhcModT'
, runGhcModT''
, hoistGhcModT
, runGmlT
, runGmlT'
@ -60,45 +60,42 @@ withGhcModEnv = withGhcModEnv' withCradle
withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> (Cradle -> m a) -> m a) -> FilePath -> Options -> (GhcModEnv -> m a) -> m a
withGhcModEnv' withCradle dir opts f =
withStdoutGateway $
withCradle dir $ \crdl ->
withCradleRootDir crdl $
f $ GhcModEnv opts crdl
withCradle dir $ \crdl ->
withCradleRootDir crdl $
f $ GhcModEnv opts crdl
where
withStdoutGateway a = do
c <- gmoChan <$> gmoAsk
gbracket_ (liftIO $ forkIO $ stdoutGateway c) (liftIO . killThread) a
withCradleRootDir (cradleRootDir -> projdir) a = do
cdir <- liftIO $ getCurrentDirectory
eq <- liftIO $ pathsEqual projdir cdir
if not eq
then throw $ GMEWrongWorkingDirectory projdir cdir
else a
withCradleRootDir (cradleRootDir -> projdir) a =
gbracket_ (liftIO $ swapCurrentDirectory projdir)
(liftIO . setCurrentDirectory) a
pathsEqual a b = do
ca <- canonicalizePath a
cb <- canonicalizePath b
return $ ca == cb
swapCurrentDirectory ndir = do
odir <- canonicalizePath =<< getCurrentDirectory
setCurrentDirectory ndir
return odir
runGmOutT :: IOish m => Options -> GmOutT m a -> m a
runGmOutT opts ma = do
gmo <- GhcModOut (optOutput opts) <$> liftIO newChan
runGmOutT' gmo ma
gbracket_ ma mb mc = gbracket ma mb (const mc)
runGmOutT' :: IOish m => GhcModOut -> GmOutT m a -> m a
runGmOutT' gmo ma = do
gbracket_ (liftIO $ forkIO $ stdoutGateway $ gmoChan gmo)
(liftIO . killThread)
(flip runReaderT gmo $ unGmOutT ma)
-- | Run a @GhcModT m@ computation.
runGhcModT :: IOish m
runGhcModT :: (IOish m, GmOut m)
=> Options
-> GhcModT m a
-> m (Either GhcModError a, GhcModLog)
runGhcModT opt action = do
dir <- liftIO getCurrentDirectory
runGhcModT' dir opt action
runGhcModT' :: IOish m
=> FilePath
-> Options
-> GhcModT m a
-> m (Either GhcModError a, GhcModLog)
runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
gmo <- GhcModOut (optOutput opt) <$> liftIO newChan
runGmOutT gmo $
runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do
runGmOutT opt $
withGhcModEnv dir' opt $ \env ->
first (fst <$>) <$> runGhcModT'' env defaultGhcModState
first (fst <$>) <$> runGhcModT' env defaultGhcModState
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
@ -118,13 +115,13 @@ hoistGhcModT (r,l) = do
-- do with 'GhcModEnv' and 'GhcModState'.
--
-- You should probably look at 'runGhcModT' instead.
runGhcModT'' :: IOish m
runGhcModT' :: IOish m
=> GhcModEnv
-> GhcModState
-> GhcModT m a
-> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog)
runGhcModT'' r s a = do
runGhcModT' r s a = do
flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s
runGmOutT :: IOish m => GhcModOut -> GmOutT m a -> m a
runGmOutT gmo ma = flip runReaderT gmo $ unGmOutT ma
gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c
gbracket_ ma mb mc = gbracket ma mb (const mc)

View File

@ -403,6 +403,9 @@ data GhcModError
| GMEStackBootrap String
-- ^ Bootstrapping @stack@ environment failed (process exited with failure)
| GMEWrongWorkingDirectory FilePath FilePath
deriving (Eq,Show,Typeable)
instance Error GhcModError where

View File

@ -18,6 +18,7 @@ import Exception
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad
import Paths_ghc_mod
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O
@ -402,24 +403,10 @@ main = do
]
progMain :: (Options,[String]) -> IO ()
progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
progMain (globalOptions,cmdArgs) = runGmOutT globalOptions $
case globalCommands cmdArgs of
Just s -> gmPutStr s
Nothing -> do
forM_ (reverse $ optFileMappings globalOptions) $ uncurry loadMMappedFiles
ghcCommands cmdArgs
where
hndle action = do
(e, _l) <- liftIO . evaluate =<< action
case e of
Right _ ->
return ()
Left ed ->
exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed)
loadMMappedFiles from (Just to) = loadMappedFile from to
loadMMappedFiles from (Nothing) = do
src <- liftIO getFileSourceFromStdin
loadMappedFileSource from src
Nothing -> wrapGhcCommands globalOptions cmdArgs
globalCommands :: [String] -> Maybe String
globalCommands (cmd:_)
@ -433,7 +420,8 @@ legacyInteractive = do
opt <- options
prepareCabalHelper
tmpdir <- cradleTempDir <$> cradle
symdbreq <- liftIO $ newSymDbReq opt tmpdir
gmo <- gmoAsk
symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir
world <- getCurrentWorld
legacyInteractiveLoop symdbreq world
@ -523,6 +511,31 @@ getFileSourceFromStdin = do
else loop' (acc++line++"\n")
loop' ""
-- Someone please already rewrite the cmdline parsing code *weep* :'(
wrapGhcCommands :: (IOish m, GmOut m) => Options -> [String] -> m ()
wrapGhcCommands _opts [] = fatalError "No command given (try --help)"
wrapGhcCommands _opts ("root":_) = gmPutStr =<< rootInfo
wrapGhcCommands opts args = do
handleGmError $ runGhcModT opts $ handler $ do
forM_ (reverse $ optFileMappings opts) $
uncurry loadMMappedFiles
ghcCommands args
where
handleGmError action = do
(e, _l) <- liftIO . evaluate =<< action
case e of
Right _ ->
return ()
Left ed ->
exitError $ renderStyle ghcModStyle (gmeDoc ed)
loadMMappedFiles from (Just to) = loadMappedFile from to
loadMMappedFiles from (Nothing) = do
src <- liftIO getFileSourceFromStdin
loadMappedFileSource from src
ghcCommands :: IOish m => [String] -> GhcModT m ()
ghcCommands [] = fatalError "No command given (try --help)"
ghcCommands (cmd:args) = gmPutStr =<< action args
@ -544,7 +557,7 @@ ghcCommands (cmd:args) = gmPutStr =<< action args
"auto" -> autoCmd
"find" -> findSymbolCmd
"lint" -> lintCmd
"root" -> rootInfoCmd
-- "root" -> rootInfoCmd
"doc" -> pkgDocCmd
"dumpsym" -> dumpSymbolCmd
"boot" -> bootCmd
@ -559,7 +572,7 @@ newtype InvalidCommandLine = InvalidCommandLine (Either String String)
deriving (Show, Typeable)
instance Exception InvalidCommandLine
exitError :: IOish m => String -> GhcModT m a
exitError :: (MonadIO m, GmOut m) => String -> m a
exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
exitError' :: Options -> String -> IO a
@ -595,7 +608,7 @@ catchArgs cmd action =
modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd,
refineCmd, autoCmd, findSymbolCmd, lintCmd, pkgDocCmd,
dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd
:: IOish m => [String] -> GhcModT m String
@ -604,7 +617,6 @@ modulesCmd = withParseCmd' "modules" s $ \[] -> modules
languagesCmd = withParseCmd' "lang" [] $ \[] -> languages
flagsCmd = withParseCmd' "flag" [] $ \[] -> flags
debugInfoCmd = withParseCmd' "debug" [] $ \[] -> debugInfo
rootInfoCmd = withParseCmd' "root" [] $ \[] -> rootInfo
componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts
-- internal
bootCmd = withParseCmd' "boot" [] $ \[] -> boot

View File

@ -8,21 +8,22 @@ module Misc (
) where
import Control.Concurrent.Async (Async, async, wait)
import CoreMonad (liftIO)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Prelude
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad
----------------------------------------------------------------
type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
newSymDbReq :: Options -> FilePath -> IO SymDbReq
newSymDbReq opt dir = do
let act = runGhcModT opt $ loadSymbolDb dir
newSymDbReq :: Options -> GhcModOut -> FilePath -> IO SymDbReq
newSymDbReq opt gmo tmpdir = do
let act = runGmOutT' gmo $ runGhcModT opt $ loadSymbolDb tmpdir
req <- async act
ref <- newIORef req
return $ SymDbReq ref act