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.Conc
  39 import GHC.Handle
  40 import Control.Concurrent.MVar
  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 $ \ h_ ->
 138      throwErrnoIfMinus1Retry_ "flushConsole"
 139       (flush_console_fd (fromIntegral (haFD h_)))
 140
 141 foreign import ccall unsafe "consUtils.h flush_input_console__"
 142         flush_console_fd :: CInt -> IO CInt
 143 #endif /* mingw32_HOST_OS */