[project @ 2004-11-17 19:07:38 by sof]
[packages/old-time.git] / GHC / ConsoleHandler.hs
1 {-# OPTIONS -cpp #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : GHC.ConsoleHandler
5 -- Copyright : whatevah
6 -- License : see libraries/base/LICENSE
7 --
8 -- Maintainer : cvs-ghc@haskell.org
9 -- Stability : internal
10 -- Portability : non-portable (GHC extensions)
11 --
12 -- Installing Win32 console handlers.
13 --
14 -----------------------------------------------------------------------------
15 module GHC.ConsoleHandler
16 #ifndef mingw32_TARGET_OS
17 where
18 #else /* whole file */
19 ( Handler(..)
20 , installHandler
21 , ConsoleEvent(..)
22 ) where
23
24 {-
25 #include "Signals.h"
26 -}
27
28 import Foreign
29 import Foreign.C
30
31 data Handler
32 = Default
33 | Ignore
34 | Catch (ConsoleEvent -> IO ())
35
36 data ConsoleEvent
37 = ControlC
38 | Break
39 | Close
40 -- these are sent to Services only.
41 | Logoff
42 | Shutdown
43
44 installHandler :: Handler -> IO Handler
45 installHandler handler =
46 alloca $ \ p_sp -> do
47 rc <-
48 case handler of
49 Default -> rts_installHandler STG_SIG_DFL p_sp
50 Ignore -> rts_installHandler STG_SIG_IGN p_sp
51 Catch h -> do
52 v <- newStablePtr (toHandler h)
53 poke p_sp v
54 rts_installHandler STG_SIG_HAN p_sp
55 case rc of
56 STG_SIG_DFL -> return Default
57 STG_SIG_IGN -> return Ignore
58 STG_SIG_HAN -> do
59 osptr <- peek p_sp
60 oldh <- deRefStablePtr osptr
61 -- stable pointer is no longer in use, free it.
62 freeStablePtr osptr
63 return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
64 where
65 toConsoleEvent ev =
66 case ev of
67 0 {- CTRL_C_EVENT-} -> Just ControlC
68 1 {- CTRL_BREAK_EVENT-} -> Just Break
69 2 {- CTRL_CLOSE_EVENT-} -> Just Close
70 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
71 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
72 _ -> Nothing
73 fromConsoleEvent ev =
74 case ev of
75 ControlC -> 0 {- CTRL_C_EVENT-}
76 Break -> 1 {- CTRL_BREAK_EVENT-}
77 Close -> 2 {- CTRL_CLOSE_EVENT-}
78 Logoff -> 5 {- CTRL_LOGOFF_EVENT-}
79 Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
80
81 toHandler hdlr ev = do
82 case toConsoleEvent ev of
83 Just x -> hdlr x
84 Nothing -> return () -- silently ignore..
85
86 foreign import ccall unsafe "Signals.h stg_InstallConsoleEvent"
87 rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
88 #endif /* mingw32_TARGET_OS */