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