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:
parent
6488f1070d
commit
56902bfe2d
@ -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
|
||||
|
@ -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 _) =
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user