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