[project @ 2005-04-22 17:00:49 by sof]
[packages/pretty.git] / GHC / ConsoleHandler.hs
1 {-# OPTIONS_GHC -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
16 module GHC.ConsoleHandler
17 #ifndef mingw32_HOST_OS
18 where
19 import Prelude -- necessary to get dependencies right
20 #else /* whole file */
21 ( Handler(..)
22 , installHandler
23 , ConsoleEvent(..)
24 ) where
25
26 {-
27 #include "Signals.h"
28 -}
29
30 import Prelude -- necessary to get dependencies right
31
32 import Foreign
33 import Foreign.C
34
35 data Handler
36 = Default
37 | Ignore
38 | Catch (ConsoleEvent -> IO ())
39
40 data ConsoleEvent
41 = ControlC
42 | Break
43 | Close
44 -- these are sent to Services only.
45 | Logoff
46 | Shutdown
47
48 installHandler :: Handler -> IO Handler
49 installHandler handler =
50 alloca $ \ p_sp -> do
51 rc <-
52 case handler of
53 Default -> rts_installHandler STG_SIG_DFL p_sp
54 Ignore -> rts_installHandler STG_SIG_IGN p_sp
55 Catch h -> do
56 v <- newStablePtr (toHandler h)
57 poke p_sp v
58 rts_installHandler STG_SIG_HAN p_sp
59 case rc of
60 STG_SIG_DFL -> return Default
61 STG_SIG_IGN -> return Ignore
62 STG_SIG_HAN -> do
63 osptr <- peek p_sp
64 oldh <- deRefStablePtr osptr
65 -- stable pointer is no longer in use, free it.
66 freeStablePtr osptr
67 return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
68 where
69 toConsoleEvent ev =
70 case ev of
71 0 {- CTRL_C_EVENT-} -> Just ControlC
72 1 {- CTRL_BREAK_EVENT-} -> Just Break
73 2 {- CTRL_CLOSE_EVENT-} -> Just Close
74 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
75 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
76 _ -> Nothing
77 fromConsoleEvent ev =
78 case ev of
79 ControlC -> 0 {- CTRL_C_EVENT-}
80 Break -> 1 {- CTRL_BREAK_EVENT-}
81 Close -> 2 {- CTRL_CLOSE_EVENT-}
82 Logoff -> 5 {- CTRL_LOGOFF_EVENT-}
83 Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
84
85 toHandler hdlr ev = do
86 case toConsoleEvent ev of
87 -- see rts/win32/ConsoleHandler.c for comments as to why
88 -- rts_ConsoleHandlerDone is called here.
89 Just x -> hdlr x >> rts_ConsoleHandlerDone ev
90 Nothing -> return () -- silently ignore..
91
92 foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
93 rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
94 foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
95 rts_ConsoleHandlerDone :: CInt -> IO ()
96 #endif /* mingw32_HOST_OS */