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 #else /* whole file */
  22         ( Handler(..)
  23         , installHandler
  24         , ConsoleEvent(..)
  25         , flushConsole
  26         ) where
  27
  28 {-
  29 #include "Signals.h"
  30 -}
  31
  32 import Foreign
  33 import Foreign.C
  34 import GHC.IO.FD
  35 import GHC.IO.Exception
  36 import GHC.IO.Handle.Types
  37 import GHC.IO.Handle.Internals
  38 import GHC.Conc
  39 import Control.Concurrent.MVar
  40 import Data.Typeable
  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 $ \ Handle__{haDevice=dev} ->
 138     case cast dev of
 139       Nothing -> ioException $
 140                     IOError (Just h) IllegalOperation "flushConsole"
 141                         "handle is not a file descriptor" Nothing Nothing
 142       Just fd -> do
 143         throwErrnoIfMinus1Retry_ "flushConsole" $
 144            flush_console_fd (fromIntegral (fdFD fd))
 145
 146 foreign import ccall unsafe "consUtils.h flush_input_console__"
 147         flush_console_fd :: CInt -> IO CInt
 148
 149 #endif /* mingw32_HOST_OS */