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

I would just fork() but we have to support WinDOS, gah.

Language/Haskell/GhcMod/Debug.hs

@@ -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

Language/Haskell/GhcMod/Error.hs

@@ -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 _) =

Language/Haskell/GhcMod/Monad.hs

@@ -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)

Language/Haskell/GhcMod/Types.hs

@@ -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