Remove Control.Parallel*, now in package parallel
[packages/random.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.Handle
39 import Data.Typeable
40
41 data Handler
42 = Default
43 | Ignore
44 | Catch (ConsoleEvent -> IO ())
45
46 data ConsoleEvent
47 = ControlC
48 | Break
49 | Close
50 -- these are sent to Services only.
51 | Logoff
52 | Shutdown
53 deriving (Eq, Ord, Enum, Show, Read, Typeable)
54
55 -- | Allows Windows console events to be caught and handled. To
56 -- handle a console event, call 'installHandler' passing the
57 -- appropriate 'Handler' value. When the event is received, if the
58 -- 'Handler' value is @Catch f@, then a new thread will be spawned by
59 -- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that
60 -- was received.
61 --
62 -- Note that console events can only be received by an application
63 -- running in a Windows console. Certain environments that look like consoles
64 -- do not support console events, these include:
65 --
66 -- * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@,
67 -- then a Cygwin shell behaves like a Windows console).
68 -- * Cygwin xterm and rxvt windows
69 -- * MSYS rxvt windows
70 --
71 -- In order for your application to receive console events, avoid running
72 -- it in one of these environments.
73 --
74 installHandler :: Handler -> IO Handler
75 installHandler handler =
76 alloca $ \ p_sp -> do
77 rc <-
78 case handler of
79 Default -> rts_installHandler STG_SIG_DFL p_sp
80 Ignore -> rts_installHandler STG_SIG_IGN p_sp
81 Catch h -> do
82 v <- newStablePtr (toHandler h)
83 poke p_sp v
84 rts_installHandler STG_SIG_HAN p_sp
85 case rc of
86 STG_SIG_DFL -> return Default
87 STG_SIG_IGN -> return Ignore
88 STG_SIG_HAN -> do
89 osptr <- peek p_sp
90 oldh <- deRefStablePtr osptr
91 -- stable pointer is no longer in use, free it.
92 freeStablePtr osptr
93 return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
94 where
95 toConsoleEvent ev =
96 case ev of
97 0 {- CTRL_C_EVENT-} -> Just ControlC
98 1 {- CTRL_BREAK_EVENT-} -> Just Break
99 2 {- CTRL_CLOSE_EVENT-} -> Just Close
100 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
101 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
102 _ -> Nothing
103 fromConsoleEvent ev =
104 case ev of
105 ControlC -> 0 {- CTRL_C_EVENT-}
106 Break -> 1 {- CTRL_BREAK_EVENT-}
107 Close -> 2 {- CTRL_CLOSE_EVENT-}
108 Logoff -> 5 {- CTRL_LOGOFF_EVENT-}
109 Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
110
111 toHandler hdlr ev = do
112 case toConsoleEvent ev of
113 -- see rts/win32/ConsoleHandler.c for comments as to why
114 -- rts_ConsoleHandlerDone is called here.
115 Just x -> hdlr x >> rts_ConsoleHandlerDone ev
116 Nothing -> return () -- silently ignore..
117
118 foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
119 rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
120 foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
121 rts_ConsoleHandlerDone :: CInt -> IO ()
122
123
124 flushConsole :: Handle -> IO ()
125 flushConsole h =
126 wantReadableHandle "flushConsole" h $ \ h_ ->
127 throwErrnoIfMinus1Retry_ "flushConsole"
128 (flush_console_fd (fromIntegral (haFD h_)))
129
130 foreign import ccall unsafe "consUtils.h flush_input_console__"
131 flush_console_fd :: CInt -> IO CInt
132 #endif /* mingw32_HOST_OS */