blob: 761926db4f982bfbbb9fced4e24f5fce55aa48ef (
plain)
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
|
{-# OPTIONS_GHC -cpp #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.ConsoleHandler
-- Copyright : whatevah
-- License : see libraries/base/LICENSE
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
-- Portability : non-portable (GHC extensions)
--
-- Installing Win32 console handlers.
--
-----------------------------------------------------------------------------
module GHC.ConsoleHandler
#ifndef mingw32_TARGET_OS
where
import Prelude -- necessary to get dependencies right
#else /* whole file */
( Handler(..)
, installHandler
, ConsoleEvent(..)
) where
{-
#include "Signals.h"
-}
import Prelude -- necessary to get dependencies right
import Foreign
import Foreign.C
data Handler
= Default
| Ignore
| Catch (ConsoleEvent -> IO ())
data ConsoleEvent
= ControlC
| Break
| Close
-- these are sent to Services only.
| Logoff
| Shutdown
installHandler :: Handler -> IO Handler
installHandler handler =
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
toConsoleEvent ev =
case ev of
0 {- CTRL_C_EVENT-} -> Just ControlC
1 {- CTRL_BREAK_EVENT-} -> Just Break
2 {- CTRL_CLOSE_EVENT-} -> Just Close
5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
_ -> Nothing
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 toConsoleEvent ev of
Just x -> hdlr x
Nothing -> return () -- silently ignore..
foreign import ccall unsafe "Signals.h stg_InstallConsoleEvent"
rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
#endif /* mingw32_TARGET_OS */
|
