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 :: (IOish m, GmOut m) => m String
-rootInfo = convert' =<< cradleRootDir <$> cradle
+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 ->
-      withCradle dir $ \crdl ->
+      withCradleRootDir crdl $
-        withCradleRootDir crdl $
+        f $ GhcModEnv opts crdl
-          f $ GhcModEnv opts crdl
  where
-   withStdoutGateway a = do
+   withCradleRootDir (cradleRootDir -> projdir) a = do
-       c <- gmoChan <$> gmoAsk
+       cdir <- liftIO $ getCurrentDirectory
-       gbracket_ (liftIO $ forkIO $ stdoutGateway c) (liftIO . killThread) a
+       eq <- liftIO $ pathsEqual projdir cdir
+       if not eq
+          then throw $ GMEWrongWorkingDirectory projdir cdir
+          else a
 
-   withCradleRootDir (cradleRootDir -> projdir) a =
+   pathsEqual a b = do
-       gbracket_ (liftIO $ swapCurrentDirectory projdir)
+     ca <- canonicalizePath a
-                 (liftIO . setCurrentDirectory) a
+     cb <- canonicalizePath b
+     return $ ca == cb
 
-   swapCurrentDirectory ndir = do
+runGmOutT :: IOish m => Options -> GmOutT m a -> m a
-     odir <- canonicalizePath =<< getCurrentDirectory
+runGmOutT opts ma = do
-     setCurrentDirectory ndir
+    gmo <- GhcModOut (optOutput opts) <$> liftIO newChan
-     return odir
+    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
+runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do
-    dir <- liftIO getCurrentDirectory
+    runGmOutT opt $
-    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 $
       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
+gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c
-runGmOutT gmo ma = flip runReaderT gmo $ unGmOutT ma
+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

src/GHCMod.hs

@@ -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
+      Nothing -> wrapGhcCommands globalOptions cmdArgs
-        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
 
 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

src/Misc.hs

@@ -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 :: Options -> GhcModOut -> FilePath -> IO SymDbReq
-newSymDbReq opt dir = do
+newSymDbReq opt gmo tmpdir = do
-    let act = runGhcModT opt $ loadSymbolDb dir
+    let act = runGmOutT' gmo $ runGhcModT opt $ loadSymbolDb tmpdir
     req <- async act
     ref <- newIORef req
     return $ SymDbReq ref act