Setting current directory

Author: mvoidex

src/Client.hs

@@ -17,6 +17,7 @@ import Network (PortID(UnixSocket))
 import System.Exit (exitFailure, exitWith)
 import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn, stderr)
 import System.IO.Error (isDoesNotExistError)
+import System.Directory (getCurrentDirectory)
 
 import Daemonize (daemonize)
 import Server (createListenSocket, startServer)
@@ -42,7 +43,8 @@ serverCommand sock cmd ghcOpts = do
     r <- tryJust (guard . isDoesNotExistError) (connect sock)
     case r of
         Right h -> do
-            hPutStrLn h $ show (SrvCommand cmd ghcOpts)
+            cwd <- getCurrentDirectory
+            hPutStrLn h $ show (SrvCommand cwd cmd ghcOpts)
             hFlush h
             startClientReadLoop h
         Left _ -> do

src/CommandLoop.hs

@@ -9,6 +9,7 @@ import Data.IORef
 import Data.List (find)
 import MonadUtils (MonadIO, liftIO)
 import System.Exit (ExitCode(ExitFailure, ExitSuccess))
+import System.Directory (setCurrentDirectory)
 import qualified ErrUtils
 import qualified Exception (ExceptionMonad)
 import qualified GHC
@@ -18,7 +19,7 @@ import qualified Outputable
 import Types (ClientDirective(..), Command(..))
 import Info (getIdentifierInfo, getType)
 
-type CommandObj = (Command, [String])
+type CommandObj = (FilePath, (Command, [String]))
 
 type ClientSend = ClientDirective -> IO ()
 
@@ -44,22 +45,22 @@ withWarnings state warningsValue action = do
     setWarnings :: Bool -> IO ()
     setWarnings val = modifyIORef state $ \s -> s { stateWarningsEnabled = val }
 
-startCommandLoop :: IORef State -> ClientSend -> IO (Maybe CommandObj) -> [String] -> Maybe Command -> IO ()
+startCommandLoop :: IORef State -> ClientSend -> IO (Maybe CommandObj) -> [String] -> Maybe (FilePath, Command) -> IO ()
 startCommandLoop state clientSend getNextCommand initialGhcOpts mbInitial = do
     continue <- GHC.runGhc (Just GHC.Paths.libdir) $ do
         configOk <- GHC.gcatch (configSession state clientSend initialGhcOpts >> return True)
             handleConfigError
         if configOk
             then do
-                doMaybe mbInitial $ \cmd -> sendErrors (runCommand state clientSend cmd)
+                doMaybe mbInitial $ \(cwd, cmd) -> liftIO (setCurrentDirectory cwd) >> sendErrors (runCommand state clientSend cmd)
                 processNextCommand False
             else processNextCommand True
 
     case continue of
         Nothing ->
             -- Exit
             return ()
-        Just (cmd, ghcOpts) -> startCommandLoop state clientSend getNextCommand ghcOpts (Just cmd)
+        Just (cwd, (cmd, ghcOpts)) -> startCommandLoop state clientSend getNextCommand ghcOpts (Just (cwd, cmd))
     where
     processNextCommand :: Bool -> GHC.Ghc (Maybe CommandObj)
     processNextCommand forceReconfig = do
@@ -68,10 +69,10 @@ startCommandLoop state clientSend getNextCommand initialGhcOpts mbInitial = do
             Nothing ->
                 -- Exit
                 return Nothing
-            Just (cmd, ghcOpts) ->
+            Just (cwd, (cmd, ghcOpts)) ->
                 if forceReconfig || (ghcOpts /= initialGhcOpts)
-                    then return (Just (cmd, ghcOpts))
-                    else sendErrors (runCommand state clientSend cmd) >> processNextCommand False
+                    then return (Just (cwd, (cmd, ghcOpts)))
+                    else sendErrors (liftIO (setCurrentDirectory cwd) >> runCommand state clientSend cmd) >> processNextCommand False
 
     sendErrors :: GHC.Ghc () -> GHC.Ghc ()
     sendErrors action = GHC.gcatch action (\x -> handleConfigError x >> return ())

src/Server.hs

@@ -57,7 +57,7 @@ clientSend currentClient clientDirective = do
     ignoreEPipe = handleJust (guard . isEPipe) (const $ return ())
     isEPipe = (==ResourceVanished) . ioeGetErrorType
 
-getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (Command, [String]))
+getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (FilePath, (Command, [String])))
 getNextCommand currentClient sock = do
     checkCurrent <- readIORef currentClient
     case checkCurrent of
@@ -72,8 +72,8 @@ getNextCommand currentClient sock = do
             clientSend currentClient $ ClientUnexpectedError $
                 "The client sent an invalid message to the server: " ++ show msg
             getNextCommand currentClient sock
-        Just (SrvCommand cmd ghcOpts) -> do
-            return $ Just (cmd, ghcOpts)
+        Just (SrvCommand cwd cmd ghcOpts) -> do
+            return $ Just (cwd, (cmd, ghcOpts))
         Just SrvStatus -> do
             mapM_ (clientSend currentClient) $
                 [ ClientStdout "Server is running."

src/Types.hs

@@ -7,7 +7,7 @@ module Types
 import System.Exit (ExitCode)
 
 data ServerDirective
-    = SrvCommand Command [String]
+    = SrvCommand FilePath Command [String]
     | SrvStatus
     | SrvExit
     deriving (Read, Show)