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