From 6e240f6d58043ce9f4dff1dcbbfa0d5a2f913b04 Mon Sep 17 00:00:00 2001 From: mvoidex Date: Sat, 16 Mar 2013 06:07:22 +0400 Subject: [PATCH 1/6] Ported to Win32 --- hdevtools.cabal | 9 ++++++++- src/Client.hs | 18 ++++++++++-------- src/Daemonize.hs | 45 ++++++++++++++++++++++++++++++++------------- src/Main.hs | 7 +++---- src/Server.hs | 17 ++++++++++------- src/Util.hs | 25 +++++++++++++++++++++++++ 6 files changed, 88 insertions(+), 33 deletions(-) diff --git a/hdevtools.cabal b/hdevtools.cabal index 2c34b96..d41f308 100644 --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -64,5 +64,12 @@ executable hdevtools ghc-paths, syb, network, - time, + time + + if os(windows) + build-depends: + filepath == 1.3.*, + process == 1.1.* + else + build-depends: unix diff --git a/src/Client.hs b/src/Client.hs index 71c14b8..ec7d530 100644 --- a/src/Client.hs +++ b/src/Client.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Client ( getServerStatus , stopServer @@ -6,7 +8,12 @@ module Client import Control.Exception (tryJust) import Control.Monad (guard) -import Network (PortID(UnixSocket), connectTo) +import Network (connectTo) +#ifdef mingw32_HOST_OS +import Network (PortID(PortNumber)) +#else +import Network (PortID(UnixSocket)) +#endif import System.Exit (exitFailure, exitWith) import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) @@ -14,11 +21,7 @@ import System.IO.Error (isDoesNotExistError) import Daemonize (daemonize) import Server (createListenSocket, startServer) import Types (ClientDirective(..), Command(..), ServerDirective(..)) -import Util (readMaybe) - -connect :: FilePath -> IO Handle -connect sock = do - connectTo "" (UnixSocket sock) +import Util (readMaybe, connect) getServerStatus :: FilePath -> IO () getServerStatus sock = do @@ -43,8 +46,7 @@ serverCommand sock cmd ghcOpts = do hFlush h startClientReadLoop h Left _ -> do - s <- createListenSocket sock - daemonize False $ startServer sock (Just s) + daemonize False sock serverCommand sock cmd ghcOpts startClientReadLoop :: Handle -> IO () diff --git a/src/Daemonize.hs b/src/Daemonize.hs index 7deb9e1..285b31f 100644 --- a/src/Daemonize.hs +++ b/src/Daemonize.hs @@ -1,30 +1,49 @@ +{-# LANGUAGE CPP #-} + module Daemonize ( daemonize ) where -import Control.Monad (when) +import Control.Monad (when, void) import System.Exit (ExitCode(ExitSuccess)) +#ifdef mingw32_HOST_OS +import System.Environment +import System.Exit (exitSuccess) +import System.Process +#else import System.Posix.Process (exitImmediately, createSession, forkProcess) import System.Posix.IO +#endif + +import Server (createListenSocket, startServer) -- | This goes against the common daemon guidelines and does not change the -- current working directory! -- -- We need the daemon to stay in the current directory for the GHC API to work -daemonize :: Bool -> IO () -> IO () -daemonize exit program = do +daemonize :: Bool -> FilePath -> IO () +#ifdef mingw32_HOST_OS +daemonize exit sock = do + exePath <- getExecutablePath + void $ createProcess $ (proc exePath ["admin", "--socket=" ++ sock, "--start-server", "-n"]) { + close_fds = True } + when exit exitSuccess +#else +daemonize exit sock = do + s <- createListenSocket sock _ <- forkProcess child1 when exit $ exitImmediately ExitSuccess where - child1 = do - _ <- createSession - _ <- forkProcess child2 - exitImmediately ExitSuccess + child1 = do + _ <- createSession + _ <- forkProcess child2 + exitImmediately ExitSuccess - child2 = do - mapM_ closeFd [stdInput, stdOutput, stdError] - nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags - mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] - closeFd nullFd - program + child2 = do + mapM_ closeFd [stdInput, stdOutput, stdError] + nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags + mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError] + closeFd nullFd + startServer sock (Just s) +#endif diff --git a/src/Main.hs b/src/Main.hs index 517f224..6e56687 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,12 +1,12 @@ module Main where -import System.Environment (getProgName) +import System.Environment (getProgName, getExecutablePath) import System.IO (hPutStrLn, stderr) import Client (getServerStatus, serverCommand, stopServer) import CommandArgs -import Daemonize (daemonize) import Server (startServer, createListenSocket) +import Daemonize (daemonize) import Types (Command(..)) defaultSocketFilename :: FilePath @@ -32,8 +32,7 @@ doAdmin sock args | start_server args = if noDaemon args then startServer sock Nothing else do - s <- createListenSocket sock - daemonize True $ startServer sock (Just s) + daemonize True sock | status args = getServerStatus sock | stop_server args = stopServer sock | otherwise = do diff --git a/src/Server.hs b/src/Server.hs index 551e2c4..3d7ef17 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,10 +1,17 @@ -module Server where +{-# LANGUAGE CPP #-} + +module Server + ( startServer + , createListenSocket + , clientSend + , getNextCommand + ) where import Control.Exception (bracket, finally, handleJust, tryJust) import Control.Monad (guard) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import GHC.IO.Exception (IOErrorType(ResourceVanished)) -import Network (PortID(UnixSocket), Socket, accept, listenOn, sClose) +import Network (Socket, accept, listenOn, sClose) import System.Directory (removeFile) import System.Exit (ExitCode(ExitSuccess)) import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn) @@ -12,11 +19,7 @@ import System.IO.Error (ioeGetErrorType, isDoesNotExistError) import CommandLoop (newCommandLoopState, startCommandLoop) import Types (ClientDirective(..), Command, ServerDirective(..)) -import Util (readMaybe) - -createListenSocket :: FilePath -> IO Socket -createListenSocket socketPath = - listenOn (UnixSocket socketPath) +import Util (readMaybe, createListenSocket) startServer :: FilePath -> Maybe Socket -> IO () startServer socketPath mbSock = do diff --git a/src/Util.hs b/src/Util.hs index dd4984d..a14ae94 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -1,10 +1,35 @@ +{-# LANGUAGE CPP #-} + module Util ( readMaybe + , createListenSocket + , connect ) where +import Network +import System.IO (Handle) + -- Taken from: -- http://stackoverflow.com/questions/8066850/why-doesnt-haskells-prelude-read-return-a-maybe/8080084#8080084 readMaybe :: (Read a) => String -> Maybe a readMaybe s = case [x | (x,t) <- reads s, ("","") <- lex t] of [x] -> Just x _ -> Nothing + +createListenSocket :: FilePath -> IO Socket +#ifdef mingw32_HOST_OS +createListenSocket socketPath = + listenOn (PortNumber $ fromInteger $ read socketPath) +#else +createListenSocket socketPath = + listenOn (UnixSocket socketPath) +#endif + +connect :: FilePath -> IO Handle +#ifdef mingw32_HOST_OS +connect sock = do + connectTo "" (PortNumber $ fromInteger $ read sock) +#else +connect sock = do + connectTo "" (UnixSocket sock) +#endif From 7af8f19c1b4ab6abe8d83c74208b5cadcd689727 Mon Sep 17 00:00:00 2001 From: mvoidex Date: Sat, 16 Mar 2013 06:13:00 +0400 Subject: [PATCH 2/6] Changed default socket name --- src/Main.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Main.hs b/src/Main.hs index 6e56687..a55056a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Main where import System.Environment (getProgName, getExecutablePath) @@ -10,7 +12,11 @@ import Daemonize (daemonize) import Types (Command(..)) defaultSocketFilename :: FilePath +#ifdef mingw32_HOST_OS +defaultSocketFilename = show 43210 +#else defaultSocketFilename = ".hdevtools.sock" +#endif getSocketFilename :: Maybe FilePath -> FilePath getSocketFilename Nothing = defaultSocketFilename From a7e06a13793c7da08c60d5fe4586a4bf5954cdd6 Mon Sep 17 00:00:00 2001 From: mvoidex Date: Sat, 16 Mar 2013 09:19:53 +0400 Subject: [PATCH 3/6] Setting current directory --- src/Client.hs | 4 +++- src/CommandLoop.hs | 15 ++++++++------- src/Server.hs | 6 +++--- src/Types.hs | 2 +- 4 files changed, 15 insertions(+), 12 deletions(-) diff --git a/src/Client.hs b/src/Client.hs index ec7d530..dd50d4e 100644 --- a/src/Client.hs +++ b/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 diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index 1a62ca3..4d5db98 100644 --- a/src/CommandLoop.hs +++ b/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,14 +45,14 @@ 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 @@ -59,7 +60,7 @@ startCommandLoop state clientSend getNextCommand initialGhcOpts mbInitial = do 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 ()) diff --git a/src/Server.hs b/src/Server.hs index 3d7ef17..ac53789 100644 --- a/src/Server.hs +++ b/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." diff --git a/src/Types.hs b/src/Types.hs index 9b50707..8c380f2 100644 --- a/src/Types.hs +++ b/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) From cb81487951e1a03598f5d7a31aaa951a6fa9ab84 Mon Sep 17 00:00:00 2001 From: mvoidex Date: Sat, 16 Mar 2013 10:00:48 +0400 Subject: [PATCH 4/6] Revert "Setting current directory" This reverts commit a7e06a13793c7da08c60d5fe4586a4bf5954cdd6. --- src/Client.hs | 4 +--- src/CommandLoop.hs | 15 +++++++-------- src/Server.hs | 6 +++--- src/Types.hs | 2 +- 4 files changed, 12 insertions(+), 15 deletions(-) diff --git a/src/Client.hs b/src/Client.hs index dd50d4e..ec7d530 100644 --- a/src/Client.hs +++ b/src/Client.hs @@ -17,7 +17,6 @@ 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) @@ -43,8 +42,7 @@ serverCommand sock cmd ghcOpts = do r <- tryJust (guard . isDoesNotExistError) (connect sock) case r of Right h -> do - cwd <- getCurrentDirectory - hPutStrLn h $ show (SrvCommand cwd cmd ghcOpts) + hPutStrLn h $ show (SrvCommand cmd ghcOpts) hFlush h startClientReadLoop h Left _ -> do diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs index 4d5db98..1a62ca3 100644 --- a/src/CommandLoop.hs +++ b/src/CommandLoop.hs @@ -9,7 +9,6 @@ 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 @@ -19,7 +18,7 @@ import qualified Outputable import Types (ClientDirective(..), Command(..)) import Info (getIdentifierInfo, getType) -type CommandObj = (FilePath, (Command, [String])) +type CommandObj = (Command, [String]) type ClientSend = ClientDirective -> IO () @@ -45,14 +44,14 @@ 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 (FilePath, Command) -> IO () +startCommandLoop :: IORef State -> ClientSend -> IO (Maybe CommandObj) -> [String] -> Maybe 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 $ \(cwd, cmd) -> liftIO (setCurrentDirectory cwd) >> sendErrors (runCommand state clientSend cmd) + doMaybe mbInitial $ \cmd -> sendErrors (runCommand state clientSend cmd) processNextCommand False else processNextCommand True @@ -60,7 +59,7 @@ startCommandLoop state clientSend getNextCommand initialGhcOpts mbInitial = do Nothing -> -- Exit return () - Just (cwd, (cmd, ghcOpts)) -> startCommandLoop state clientSend getNextCommand ghcOpts (Just (cwd, cmd)) + Just (cmd, ghcOpts) -> startCommandLoop state clientSend getNextCommand ghcOpts (Just cmd) where processNextCommand :: Bool -> GHC.Ghc (Maybe CommandObj) processNextCommand forceReconfig = do @@ -69,10 +68,10 @@ startCommandLoop state clientSend getNextCommand initialGhcOpts mbInitial = do Nothing -> -- Exit return Nothing - Just (cwd, (cmd, ghcOpts)) -> + Just (cmd, ghcOpts) -> if forceReconfig || (ghcOpts /= initialGhcOpts) - then return (Just (cwd, (cmd, ghcOpts))) - else sendErrors (liftIO (setCurrentDirectory cwd) >> runCommand state clientSend cmd) >> processNextCommand False + then return (Just (cmd, ghcOpts)) + else sendErrors (runCommand state clientSend cmd) >> processNextCommand False sendErrors :: GHC.Ghc () -> GHC.Ghc () sendErrors action = GHC.gcatch action (\x -> handleConfigError x >> return ()) diff --git a/src/Server.hs b/src/Server.hs index ac53789..3d7ef17 100644 --- a/src/Server.hs +++ b/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 (FilePath, (Command, [String]))) +getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (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 cwd cmd ghcOpts) -> do - return $ Just (cwd, (cmd, ghcOpts)) + Just (SrvCommand cmd ghcOpts) -> do + return $ Just (cmd, ghcOpts) Just SrvStatus -> do mapM_ (clientSend currentClient) $ [ ClientStdout "Server is running." diff --git a/src/Types.hs b/src/Types.hs index 8c380f2..9b50707 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -7,7 +7,7 @@ module Types import System.Exit (ExitCode) data ServerDirective - = SrvCommand FilePath Command [String] + = SrvCommand Command [String] | SrvStatus | SrvExit deriving (Read, Show) From cd380a71575c6802b6491995ad89f82d4e1bfe10 Mon Sep 17 00:00:00 2001 From: mvoidex Date: Thu, 6 Nov 2014 22:06:19 +0300 Subject: [PATCH 5/6] Dump deps --- hdevtools.cabal | 6 +++--- src/Info.hs | 25 +++++++++++-------------- 2 files changed, 14 insertions(+), 17 deletions(-) diff --git a/hdevtools.cabal b/hdevtools.cabal index d41f308..cb5b42e 100644 --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -60,7 +60,7 @@ executable hdevtools build-depends: base == 4.*, cmdargs, directory, - ghc >= 7.2, + ghc >= 7.8, ghc-paths, syb, network, @@ -68,8 +68,8 @@ executable hdevtools if os(windows) build-depends: - filepath == 1.3.*, - process == 1.1.* + filepath, + process else build-depends: unix diff --git a/src/Info.hs b/src/Info.hs index b9dedb5..be0f9e6 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -127,13 +127,13 @@ getSrcSpan (GHC.RealSrcSpan spn) = getSrcSpan _ = Nothing getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) -getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ) +getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MG _ _ typ _}) = return $ Just (spn, typ) getTypeLHsBind _ _ = return Nothing getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type)) getTypeLHsExpr tcm e = do hs_env <- GHC.getSession - (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env modu rn_env ty_env e + (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env e return () case mbe of Nothing -> return Nothing @@ -161,14 +161,14 @@ pretty dflags = pretty :: GHC.Type -> String pretty = #endif - Pretty.showDocWith Pretty.OneLineMode + Pretty.showDoc Pretty.OneLineMode 0 #if __GLASGOW_HASKELL__ >= 706 . Outputable.withPprStyleDoc dflags #else . Outputable.withPprStyleDoc #endif (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay) - . PprTyThing.pprTypeForUser False + . PprTyThing.pprTypeForUser ------------------------------------------------------------------------------ -- The following was taken from 'ghc-syb-utils' @@ -198,8 +198,8 @@ everythingStaged stage k z f x infoThing :: String -> GHC.Ghc String infoThing str = do names <- GHC.parseName str - mb_stuffs <- mapM GHC.getInfo names - let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) + mb_stuffs <- mapM (GHC.getInfo True) names + let filtered = filterOutChildren (\(t,_f,_i,_x) -> t) (catMaybes mb_stuffs) unqual <- GHC.getPrintUnqual #if __GLASGOW_HASKELL__ >= 706 dflags <- DynFlags.getDynFlags @@ -207,7 +207,7 @@ infoThing str = do #else return $ Outputable.showSDocForUser unqual $ #endif - Outputable.vcat (intersperse (Outputable.text "") $ map (pprInfo False) filtered) + Outputable.vcat (intersperse (Outputable.text "") $ map pprInfo filtered) -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data @@ -225,15 +225,12 @@ filterOutChildren get_thing xs Just p -> GHC.getName p `NameSet.elemNameSet` all_names Nothing -> False -#if __GLASGOW_HASKELL__ >= 706 -pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst]) -> Outputable.SDoc -#else -pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.Instance]) -> Outputable.SDoc -#endif -pprInfo pefas (thing, fixity, insts) = - PprTyThing.pprTyThingInContextLoc pefas thing +pprInfo :: (HscTypes.TyThing, GHC.Fixity, [GHC.ClsInst], [GHC.FamInst]) -> Outputable.SDoc +pprInfo (thing, fixity, insts, fams) = + PprTyThing.pprTyThingInContextLoc thing Outputable.$$ show_fixity fixity Outputable.$$ Outputable.vcat (map GHC.pprInstance insts) + Outputable.$$ Outputable.vcat (map GHC.pprFamInst fams) where show_fixity fix | fix == GHC.defaultFixity = Outputable.empty From 1b9557a2bf0ad272d4a4b8b14de3107f208eeaa1 Mon Sep 17 00:00:00 2001 From: Maksym Ivanov Date: Mon, 24 Nov 2014 14:08:14 +0200 Subject: [PATCH 6/6] add CWD in server status output --- src/Server.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Server.hs b/src/Server.hs index 3d7ef17..beeb071 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -12,7 +12,7 @@ import Control.Monad (guard) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import GHC.IO.Exception (IOErrorType(ResourceVanished)) import Network (Socket, accept, listenOn, sClose) -import System.Directory (removeFile) +import System.Directory (removeFile, getCurrentDirectory) import System.Exit (ExitCode(ExitSuccess)) import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn) import System.IO.Error (ioeGetErrorType, isDoesNotExistError) @@ -75,8 +75,10 @@ getNextCommand currentClient sock = do Just (SrvCommand cmd ghcOpts) -> do return $ Just (cmd, ghcOpts) Just SrvStatus -> do + cwd <- getCurrentDirectory mapM_ (clientSend currentClient) $ [ ClientStdout "Server is running." + , ClientStdout ("Server CWD is " ++ cwd) , ClientExit ExitSuccess ] getNextCommand currentClient sock