git.iko.soy/project-m36
on 18f736a help sign in
project-m36/src/lib/ProjectM36/Win32Handle.hs
57 lines 2.6 kB history raw
1{-# LANGUAGE CPP #-}
2module ProjectM36.Win32Handle where
3import System.Win32.Types
4import Control.Exception (bracket)
5import Foreign.StablePtr
6import Foreign.C.Types
7import Control.Concurrent.MVar
9#if __GLASGOW_HASKELL__ >= 612
10import GHC.IO.Handle.Types (Handle(..), Handle__(..))
11import GHC.IO.FD (FD(..)) -- A wrapper around an Int32
12import Data.Typeable
13#else
14import GHC.IOBase (Handle(..), Handle__(..))
15import qualified GHC.IOBase as IOBase (FD) -- Just an Int32
16#endif
18-- This essential function comes from the C runtime system. It is certainly provided by msvcrt, and also seems to be provided by the mingw C library - hurrah!
19#if __GLASGOW_HASKELL__ >= 612
20foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: CInt -> IO HANDLE
21#else
22foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: IOBase.FD -> IO HANDLE
23#endif
25-- copied from ansi-terminal package
26-- | This bit is all highly dubious. The problem is that we want to output ANSI to arbitrary Handles rather than forcing
27-- people to use stdout. However, the Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need to be able
28-- to extract one of those from the Haskell Handle.
29--
30-- This code accomplishes this, albeit at the cost of only being compatible with GHC.
31withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
32withHandleToHANDLE haskell_handle action =
33 -- Create a stable pointer to the Handle. This prevents the garbage collector
34 -- getting to it while we are doing horrible manipulations with it, and hence
35 -- stops it being finalized (and closed).
36 withStablePtr haskell_handle $ const $ do
37 -- Grab the write handle variable from the Handle
38 let write_handle_mvar = case haskell_handle of
39 FileHandle _ handle_mvar -> handle_mvar
40 DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, we could also take the "read" one
42 -- Get the FD from the algebraic data type
43#if __GLASGOW_HASKELL__ < 612
44 fd <- haFD <$> readMVar write_handle_mvar
45#else
46 --readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) -> print (typeOf dev)
47 Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar
48#endif
50 -- Finally, turn that (C-land) FD into a HANDLE using msvcrt
51 windows_handle <- cget_osfhandle fd
53 -- Do what the user originally wanted
54 action windows_handle
56withStablePtr :: a -> (StablePtr a -> IO b) -> IO b
57withStablePtr value = bracket (newStablePtr value) freeStablePtr