1 {-# OPTIONS_GHC -cpp #-}
2 -----------------------------------------------------------------------------
4 -- Module : GHC.ConsoleHandler
5 -- Copyright : (c) The University of Glasgow
6 -- License : see libraries/base/LICENSE
8 -- Maintainer : cvs-ghc@haskell.org
9 -- Stability : internal
10 -- Portability : non-portable (GHC extensions)
12 -- NB. the contents of this module are only available on Windows.
14 -- Installing Win32 console handlers.
16 -----------------------------------------------------------------------------
18 module GHC.ConsoleHandler
19 #if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__)
21 import Prelude -- necessary to get dependencies right
22 #else /* whole file */
33 import Prelude -- necessary to get dependencies right
44 | Catch (ConsoleEvent -> IO ())
50 -- these are sent to Services only.
53 deriving (Eq, Ord, Enum, Show, Read, Typeable)
55 installHandler :: Handler -> IO Handler
56 installHandler handler =
60 Default -> rts_installHandler STG_SIG_DFL p_sp
61 Ignore -> rts_installHandler STG_SIG_IGN p_sp
63 v <- newStablePtr (toHandler h)
65 rts_installHandler STG_SIG_HAN p_sp
67 STG_SIG_DFL -> return Default
68 STG_SIG_IGN -> return Ignore
71 oldh <- deRefStablePtr osptr
72 -- stable pointer is no longer in use, free it.
74 return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
78 0 {- CTRL_C_EVENT-} -> Just ControlC
79 1 {- CTRL_BREAK_EVENT-} -> Just Break
80 2 {- CTRL_CLOSE_EVENT-} -> Just Close
81 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff
82 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
86 ControlC -> 0 {- CTRL_C_EVENT-}
87 Break -> 1 {- CTRL_BREAK_EVENT-}
88 Close -> 2 {- CTRL_CLOSE_EVENT-}
89 Logoff -> 5 {- CTRL_LOGOFF_EVENT-}
90 Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
92 toHandler hdlr ev = do
93 case toConsoleEvent ev of
94 -- see rts/win32/ConsoleHandler.c for comments as to why
95 -- rts_ConsoleHandlerDone is called here.
96 Just x -> hdlr x >> rts_ConsoleHandlerDone ev
97 Nothing -> return () -- silently ignore..
99 foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
100 rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
101 foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
102 rts_ConsoleHandlerDone :: CInt -> IO ()
105 flushConsole :: Handle -> IO ()
107 wantReadableHandle "flushConsole" h $ \ h_ ->
108 throwErrnoIfMinus1Retry_ "flushConsole"
109 (flush_console_fd (fromIntegral (haFD h_)))
111 foreign import ccall unsafe "consUtils.h flush_input_console__"
112 flush_console_fd :: CInt -> IO CInt
113 #endif /* mingw32_HOST_OS */