winio: add support to iserv.

3 files changed, 29 insertions, 4 deletions

diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc
index 6929e538c6..778d6e08e5 100644
--- a/libraries/base/GHC/Event/Windows.hsc
+++ b/libraries/base/GHC/Event/Windows.hsc
@@ -68,7 +68,7 @@ module GHC.Event.Windows (
     module GHC.Event.Windows.ConsoleEvent
 ) where
 
--- define DEBUG 1
+-- #define DEBUG 1
 
 -- #define DEBUG_TRACE 1
 
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 6b23f913cb..d660c10932 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -618,7 +618,7 @@ getBin h get leftover = go leftover (runGetIncremental get)
    go Nothing (Partial fun) = do
      -- putStrLn "before hGetSome"
      b <- B.hGetSome h (32*1024)
-     -- printf "hGetSome: %d\n" (B.length b)
+     -- putStrLn $ "hGetSome: " ++ show (B.length b)
      if B.null b
         then return Nothing
         else go Nothing (fun (Just b))
diff --git a/libraries/libiserv/src/GHCi/Utils.hsc b/libraries/libiserv/src/GHCi/Utils.hsc
index f606eb9d94..6b6613ad1b 100644
--- a/libraries/libiserv/src/GHCi/Utils.hsc
+++ b/libraries/libiserv/src/GHCi/Utils.hsc
@@ -6,7 +6,16 @@ module GHCi.Utils
 import Foreign.C
 import GHC.IO.Handle (Handle())
 #if defined(mingw32_HOST_OS)
+import Foreign.Ptr (ptrToIntPtr)
+import GHC.IO (onException)
 import GHC.IO.Handle.FD (fdToHandle)
+import GHC.Windows (HANDLE)
+import GHC.IO.SubSystem ((<!>))
+import GHC.IO.Handle.Windows (mkHandleFromHANDLE)
+import GHC.IO.Device as IODevice
+import GHC.IO.Encoding (getLocaleEncoding)
+import GHC.IO.IOMode
+import GHC.IO.Windows.Handle (fromHANDLE, Io(), NativeHandle())
 #else
 import System.Posix
 #endif
@@ -14,12 +23,28 @@ import System.Posix
 #include <fcntl.h>     /* for _O_BINARY */
 
 -- | Gets a GHC Handle File description from the given OS Handle or POSIX fd.
-getGhcHandle :: CInt -> IO Handle
+
 #if defined(mingw32_HOST_OS)
-getGhcHandle handle = _open_osfhandle handle (#const _O_BINARY) >>= fdToHandle
+getGhcHandle :: HANDLE -> IO Handle
+getGhcHandle = getGhcHandlePOSIX <!> getGhcHandleNative
+
+getGhcHandlePOSIX :: HANDLE -> IO Handle
+getGhcHandlePOSIX handle = do
+  let intptr = ptrToIntPtr handle
+  _open_osfhandle (fromIntegral intptr) (#const _O_BINARY) >>= fdToHandle
+
+getGhcHandleNative :: HANDLE -> IO Handle
+getGhcHandleNative hwnd =
+  do mb_codec <- fmap Just getLocaleEncoding
+     let iomode = ReadWriteMode
+         native_handle = fromHANDLE hwnd :: Io NativeHandle
+     hw_type <- IODevice.devType $ native_handle
+     mkHandleFromHANDLE native_handle hw_type (show hwnd) iomode mb_codec
+       `onException` IODevice.close native_handle
 
 foreign import ccall "io.h _open_osfhandle" _open_osfhandle ::
     CInt -> CInt -> IO CInt
 #else
+getGhcHandle :: CInt -> IO Handle
 getGhcHandle fd     = fdToHandle $ Fd fd
 #endif