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