Skip to content

Switch to using Win32 for obtaining Windows handles #185

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 1 commit into from
Closed

Switch to using Win32 for obtaining Windows handles #185

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions ansi-terminal/ansi-terminal.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,7 @@ Library
Other-Modules: System.Console.ANSI.Windows.Foreign
System.Console.ANSI.Windows.Win32.Types
System.Console.ANSI.Windows.Win32.MinTTY
Build-Depends: Win32 >= 2.14
Include-Dirs: win/include
Install-Includes: HsWin32.h
C-Sources: win/c-source/errors.c
Expand Down
77 changes: 2 additions & 75 deletions ansi-terminal/win/System/Console/ANSI/Windows/Win32/Types.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -30,28 +30,17 @@ module System.Console.ANSI.Windows.Win32.Types
, withHandleToHANDLE
) where

import Control.Concurrent.MVar ( readMVar )
import Control.Exception ( bracket, throwIO )
import Control.Exception ( throwIO )
import Control.Monad ( when )
import Data.Char ( isSpace )
import Data.Typeable ( cast )
import Data.Word ( Word16, Word32 )
import Foreign.C.Error ( Errno (..), errnoToIOError )
import Foreign.C.String ( peekCWString )
import Foreign.C.Types ( CChar, CInt (..), CShort (..), CWchar )
import Foreign.Ptr ( Ptr, nullPtr )
import Foreign.StablePtr ( StablePtr, freeStablePtr, newStablePtr )
import GHC.IO.Handle.Types ( Handle (..), Handle__ (..) )
import GHC.IO.FD ( FD(..) ) -- A wrapper around an Int32
import Numeric ( showHex )
import System.IO.Error ( ioeSetErrorString )

#if defined(__IO_MANAGER_WINIO__)
import GHC.IO.Exception
( IOErrorType (InappropriateType), IOException (IOError), ioException )
import GHC.IO.SubSystem ( (<!>) )
import GHC.IO.Windows.Handle ( ConsoleHandle, Io, NativeHandle, toHANDLE )
#endif
import System.Win32.Types (withHandleToHANDLE)

type Addr = Ptr ()
type BOOL = Bool
Expand All @@ -75,68 +64,6 @@ type USHORT = Word16
type WCHAR = CWchar
type WORD = Word16

withStablePtr :: a -> (StablePtr a -> IO b) -> IO b
withStablePtr value = bracket (newStablePtr value) freeStablePtr

#if defined(__IO_MANAGER_WINIO__)

withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE = withHandleToHANDLEPosix <!> withHandleToHANDLENative

withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLENative haskell_handle action =
withStablePtr haskell_handle $ const $ do
let write_handle_mvar = case haskell_handle of
FileHandle _ handle_mvar -> handle_mvar
DuplexHandle _ _ handle_mvar -> handle_mvar
windows_handle <- readMVar write_handle_mvar >>= handle_ToHANDLE
action windows_handle
where
handle_ToHANDLE :: Handle__ -> IO HANDLE
handle_ToHANDLE (Handle__{haDevice = dev}) =
case ( cast dev :: Maybe (Io NativeHandle)
, cast dev :: Maybe (Io ConsoleHandle)) of
(Just hwnd, Nothing) -> pure $ toHANDLE hwnd
(Nothing, Just hwnd) -> pure $ toHANDLE hwnd
_ -> throwErr "not a known HANDLE"

throwErr msg = ioException $ IOError (Just haskell_handle)
InappropriateType "withHandleToHANDLENative" msg Nothing Nothing

#else

withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLE = withHandleToHANDLEPosix

#endif

withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a
withHandleToHANDLEPosix haskell_handle action =
-- Create a stable pointer to the Handle. This prevents the garbage collector
-- getting to it while we are doing horrible manipulations with it, and hence
-- stops it being finalized (and closed).
withStablePtr haskell_handle $ const $ do
-- Grab the write handle variable from the Handle
let write_handle_mvar = case haskell_handle of
FileHandle _ handle_mvar -> handle_mvar
DuplexHandle _ _ handle_mvar -> handle_mvar
-- This is "write" MVar, we could also take the "read" one

-- Get the FD from the algebraic data type
Just fd <- (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev))
<$> readMVar write_handle_mvar

-- Finally, turn that (C-land) FD into a HANDLE using msvcrt
windows_handle <- c_get_osfhandle fd
-- Do what the user originally wanted
action windows_handle

-- 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!
foreign import ccall unsafe "_get_osfhandle"
c_get_osfhandle :: CInt -> IO HANDLE

failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a
failIfNeg = failIf (< 0)

Expand Down