1 {-# OPTIONS_GHC -cpp #-}
2 -----------------------------------------------------------------------------
4 -- Module : GHC.ConsoleHandler
5 -- Copyright : (c) The University of Glasgow
6 -- License : see libraries/base/LICENSE
8 -- Maintainer : cvs-ghc@haskell.org
9 -- Stability : internal
10 -- Portability : non-portable (GHC extensions)
12 -- NB. the contents of this module are only available on Windows.
14 -- Installing Win32 console handlers.
16 -----------------------------------------------------------------------------
18 module GHC.ConsoleHandler
19 #if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__)
21 #else /* whole file */
29 #include "rts/Signals.h"
35 import GHC.IO.Exception
36 import GHC.IO.Handle.Types
37 import GHC.IO.Handle.Internals
39 import Control.Concurrent.MVar
42 #ifdef mingw32_HOST_OS
52 | Catch (ConsoleEvent -> IO ())
54 -- | Allows Windows console events to be caught and handled. To
55 -- handle a console event, call 'installHandler' passing the
56 -- appropriate 'Handler' value. When the event is received, if the
57 -- 'Handler' value is @Catch f@, then a new thread will be spawned by
58 -- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that
61 -- Note that console events can only be received by an application
62 -- running in a Windows console. Certain environments that look like consoles
63 -- do not support console events, these include:
65 -- * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@,
66 -- then a Cygwin shell behaves like a Windows console).
67 -- * Cygwin xterm and rxvt windows
68 -- * MSYS rxvt windows
70 -- In order for your application to receive console events, avoid running
71 -- it in one of these environments.
73 installHandler :: Handler -> IO Handler
74 installHandler handler
76 modifyMVar win32ConsoleHandler $ \old_h -> do
80 r <- rts_installHandler STG_SIG_DFL nullPtr
81 return (no_handler, r)
83 r <- rts_installHandler STG_SIG_IGN nullPtr
84 return (no_handler, r)
86 r <- rts_installHandler STG_SIG_HAN nullPtr
90 STG_SIG_DFL -> return Default
91 STG_SIG_IGN -> return Ignore
92 STG_SIG_HAN -> return (Catch old_h)
93 _ -> error "installHandler: Bad threaded rc value"
94 return (new_h, prev_handler)
100 Default -> rts_installHandler STG_SIG_DFL p_sp
101 Ignore -> rts_installHandler STG_SIG_IGN p_sp
103 v <- newStablePtr (toHandler h)
105 rts_installHandler STG_SIG_HAN p_sp
107 STG_SIG_DFL -> return Default
108 STG_SIG_IGN -> return Ignore
111 oldh <- deRefStablePtr osptr
112 -- stable pointer is no longer in use, free it.
114 return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
115 _ -> error "installHandler: Bad non-threaded rc value"
117 fromConsoleEvent ev =
119 ControlC -> 0 {- CTRL_C_EVENT-}
120 Break -> 1 {- CTRL_BREAK_EVENT-}
121 Close -> 2 {- CTRL_CLOSE_EVENT-}
122 Logoff -> 5 {- CTRL_LOGOFF_EVENT-}
123 Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
125 toHandler hdlr ev = do
126 case toWin32ConsoleEvent ev of
127 -- see rts/win32/ConsoleHandler.c for comments as to why
128 -- rts_ConsoleHandlerDone is called here.
129 Just x -> hdlr x >> rts_ConsoleHandlerDone ev
130 Nothing -> return () -- silently ignore..
132 no_handler = error "win32ConsoleHandler"
134 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
136 foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
137 rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
138 foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
139 rts_ConsoleHandlerDone :: CInt -> IO ()
142 flushConsole :: Handle -> IO ()
144 wantReadableHandle_ "flushConsole" h $ \ Handle__{haDevice=dev} ->
146 Nothing -> ioException $
147 IOError (Just h) IllegalOperation "flushConsole"
148 "handle is not a file descriptor" Nothing Nothing
150 throwErrnoIfMinus1Retry_ "flushConsole" $
151 flush_console_fd (fromIntegral (fdFD fd))
153 foreign import ccall unsafe "consUtils.h flush_input_console__"
154 flush_console_fd :: CInt -> IO CInt
156 #endif /* mingw32_HOST_OS */