1#include "Common-Safe-Haskell.hs" 2{-# OPTIONS_HADDOCK hide #-} 3 4{-| The Win32 library ships with GHC. Win32-2.1 first shipped with GHC 6.6 5(released October 2006). Win32-2.5.4.1 first shipped with GHC 8.2.1 (released 6July 2017), replacing Win32-2.3.1.1. 7 8The ansi-terminal library makes use of functionality in Win32-2.1 and other 9functionality first added to Win32-2.5.0.0 or Win32-2.5.1.0 (from ansi-terminal 10itself). 11 12This module provides functions available in those later versions of Win32 to a 13wider range of compilers, reducing the use of CPP pragmas in other modules. 14-} 15module System.Win32.Compat 16 ( 17 BOOL 18 , DWORD 19 , ErrCode 20 , HANDLE 21 , LPCTSTR 22 , LPDWORD 23 , SHORT -- from Win32-2.5.0.0 24 , TCHAR 25 , UINT 26 , WORD 27 , failIfFalse_ 28 , getLastError 29 , iNVALID_HANDLE_VALUE 30 , nullHANDLE 31 , withHandleToHANDLE -- from Win32-2.5.1.0 32 , withTString 33 ) where 34 35#if !MIN_VERSION_Win32(2,5,0) 36import Foreign.C.Types (CShort (..)) 37#endif 38 39#if !MIN_VERSION_Win32(2,5,1) 40import Control.Concurrent.MVar (readMVar) 41import Control.Exception (bracket) 42import Foreign.C.Types (CInt (..)) 43import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) 44import Data.Typeable (cast) 45import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 46import GHC.IO.Handle.Types (Handle (..), Handle__ (..)) 47#endif 48 49import System.Win32.Types (BOOL, DWORD, ErrCode, HANDLE, LPCTSTR, LPDWORD, 50 TCHAR, UINT, WORD, failIfFalse_, getLastError, iNVALID_HANDLE_VALUE, 51 nullHANDLE, withTString) 52 53#if MIN_VERSION_Win32(2,5,0) 54import System.Win32.Types (SHORT) 55#endif 56 57#if MIN_VERSION_Win32(2,5,1) 58import System.Win32.Types (withHandleToHANDLE) 59#endif 60 61#if !MIN_VERSION_Win32(2,5,0) 62type SHORT = CShort 63#endif 64 65#if !MIN_VERSION_Win32(2,5,1) 66 67#if defined(i386_HOST_ARCH) 68#define WINDOWS_CCONV stdcall 69#elif defined(x86_64_HOST_ARCH) 70#define WINDOWS_CCONV ccall 71#else 72#error Unknown mingw32 arch 73#endif 74 75-- | This bit is all highly dubious. The problem is that we want to output ANSI 76-- to arbitrary Handles rather than forcing people to use stdout. However, the 77-- Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need 78-- to be able to extract one of those from the Haskell Handle. 79-- 80-- This code accomplishes this, albeit at the cost of only being compatible with 81-- GHC. 82withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a 83withHandleToHANDLE haskell_handle action = 84 -- Create a stable pointer to the Handle. This prevents the garbage collector 85 -- getting to it while we are doing horrible manipulations with it, and hence 86 -- stops it being finalized (and closed). 87 withStablePtr haskell_handle $ const $ do 88 -- Grab the write handle variable from the Handle 89 let write_handle_mvar = case haskell_handle of 90 FileHandle _ handle_mvar -> handle_mvar 91 DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, 92 -- we could also take the "read" one 93 94 -- Get the FD from the algebraic data type 95 Just fd <- fmap (\(Handle__ { haDevice = dev }) -> 96 fmap fdFD (cast dev)) $ readMVar write_handle_mvar 97 98 -- Finally, turn that (C-land) FD into a HANDLE using msvcrt 99 windows_handle <- cget_osfhandle fd 100 101 -- Do what the user originally wanted 102 action windows_handle 103 104-- This essential function comes from the C runtime system. It is certainly 105-- provided by msvcrt, and also seems to be provided by the mingw C library - 106-- hurrah! 107foreign import WINDOWS_CCONV unsafe "_get_osfhandle" 108 cget_osfhandle :: CInt -> IO HANDLE 109 110withStablePtr :: a -> (StablePtr a -> IO b) -> IO b 111withStablePtr value = bracket (newStablePtr value) freeStablePtr 112#endif 113