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