1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
{-# OPTIONS_GHC -cpp #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.ConsoleHandler
-- Copyright : (c) The University of Glasgow
-- License : see libraries/base/LICENSE
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
-- Portability : non-portable (GHC extensions)
--
-- NB. the contents of this module are only available on Windows.
--
-- Installing Win32 console handlers.
--
-----------------------------------------------------------------------------
module GHC.ConsoleHandler
#if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__)
where
import Prelude -- necessary to get dependencies right
#else /* whole file */
( Handler(..)
, installHandler
, ConsoleEvent(..)
, flushConsole
) where
{-
#include "Signals.h"
-}
import Prelude -- necessary to get dependencies right
import Foreign
import Foreign.C
import GHC.IOBase
import GHC.Conc
import GHC.Handle
import Data.Typeable
import Control.Concurrent
data Handler
= Default
| Ignore
| Catch (ConsoleEvent -> IO ())
-- | Allows Windows console events to be caught and handled. To
-- handle a console event, call 'installHandler' passing the
-- appropriate 'Handler' value. When the event is received, if the
-- 'Handler' value is @Catch f@, then a new thread will be spawned by
-- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that
-- was received.
--
-- Note that console events can only be received by an application
-- running in a Windows console. Certain environments that look like consoles
-- do not support console events, these include:
--
-- * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@,
-- then a Cygwin shell behaves like a Windows console).
-- * Cygwin xterm and rxvt windows
-- * MSYS rxvt windows
--
-- In order for your application to receive console events, avoid running
-- it in one of these environments.
--
installHandler :: Handler -> IO Handler
installHandler handler
| threaded =
modifyMVar win32ConsoleHandler $ \old_h -> do
(new_h,rc) <-
case handler of
Default -> do
r <- rts_installHandler STG_SIG_DFL nullPtr
return (no_handler, r)
Ignore -> do
r <- rts_installHandler STG_SIG_IGN nullPtr
return (no_handler, r)
Catch h -> do
r <- rts_installHandler STG_SIG_HAN nullPtr
return (h, r)
prev_handler <-
case rc of
STG_SIG_DFL -> return Default
STG_SIG_IGN -> return Ignore
STG_SIG_HAN -> return (Catch old_h)
return (new_h, prev_handler)
| otherwise =
alloca $ \ p_sp -> do
rc <-
case handler of
Default -> rts_installHandler STG_SIG_DFL p_sp
Ignore -> rts_installHandler STG_SIG_IGN p_sp
Catch h -> do
v <- newStablePtr (toHandler h)
poke p_sp v
rts_installHandler STG_SIG_HAN p_sp
case rc of
STG_SIG_DFL -> return Default
STG_SIG_IGN -> return Ignore
STG_SIG_HAN -> do
osptr <- peek p_sp
oldh <- deRefStablePtr osptr
-- stable pointer is no longer in use, free it.
freeStablePtr osptr
return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
where
fromConsoleEvent ev =
case ev of
ControlC -> 0 {- CTRL_C_EVENT-}
Break -> 1 {- CTRL_BREAK_EVENT-}
Close -> 2 {- CTRL_CLOSE_EVENT-}
Logoff -> 5 {- CTRL_LOGOFF_EVENT-}
Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
toHandler hdlr ev = do
case toWin32ConsoleEvent ev of
-- see rts/win32/ConsoleHandler.c for comments as to why
-- rts_ConsoleHandlerDone is called here.
Just x -> hdlr x >> rts_ConsoleHandlerDone ev
Nothing -> return () -- silently ignore..
no_handler = error "win32ConsoleHandler"
foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
rts_ConsoleHandlerDone :: CInt -> IO ()
flushConsole :: Handle -> IO ()
flushConsole h =
wantReadableHandle "flushConsole" h $ \ h_ ->
throwErrnoIfMinus1Retry_ "flushConsole"
(flush_console_fd (fromIntegral (haFD h_)))
foreign import ccall unsafe "consUtils.h flush_input_console__"
flush_console_fd :: CInt -> IO CInt
#endif /* mingw32_HOST_OS */
|
