Ported to Win32

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

src/Client.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 module Client
     ( getServerStatus
     , stopServer
@@ -6,19 +8,20 @@ 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)
 
 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 ()

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

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,16 +198,16 @@ 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
     return $ Outputable.showSDocForUser dflags unqual $
 #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

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

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

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