diff --git a/hdevtools.cabal b/hdevtools.cabal index 2c34b96..cb5b42e 100644 --- a/hdevtools.cabal +++ b/hdevtools.cabal @@ -60,9 +60,16 @@ executable hdevtools build-depends: base == 4.*, cmdargs, directory, - ghc >= 7.2, + ghc >= 7.8, ghc-paths, syb, network, - time, + time + + if os(windows) + build-depends: + filepath, + process + 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/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 diff --git a/src/Main.hs b/src/Main.hs index 517f224..a55056a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,16 +1,22 @@ +{-# LANGUAGE CPP #-} + 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 +#ifdef mingw32_HOST_OS +defaultSocketFilename = show 43210 +#else defaultSocketFilename = ".hdevtools.sock" +#endif getSocketFilename :: Maybe FilePath -> FilePath getSocketFilename Nothing = defaultSocketFilename @@ -32,8 +38,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..beeb071 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -1,22 +1,25 @@ -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 System.Directory (removeFile) +import Network (Socket, accept, listenOn, sClose) +import System.Directory (removeFile, getCurrentDirectory) import System.Exit (ExitCode(ExitSuccess)) import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn) 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 @@ -72,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 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