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 Data.Typeable
  41 import Control.Concurrent
  42
  43 data Handler
  44  = Default
  45  | Ignore
  46  | Catch (ConsoleEvent -> IO ())
  47
  48 -- | Allows Windows console events to be caught and handled.  To
  49 -- handle a console event, call 'installHandler' passing the
  50 -- appropriate 'Handler' value.  When the event is received, if the
  51 -- 'Handler' value is @Catch f@, then a new thread will be spawned by
  52 -- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that
  53 -- was received.
  54 --
  55 -- Note that console events can only be received by an application
  56 -- running in a Windows console.  Certain environments that look like consoles
  57 -- do not support console events, these include:
  58 --
  59 --  * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@,
  60 --    then a Cygwin shell behaves like a Windows console).
  61 --  * Cygwin xterm and rxvt windows
  62 --  * MSYS rxvt windows
  63 --
  64 -- In order for your application to receive console events, avoid running
  65 -- it in one of these environments.
  66 --
  67 installHandler :: Handler -> IO Handler
  68 installHandler handler
  69   | threaded =
  70     modifyMVar win32ConsoleHandler $ \old_h -> do
  71       (new_h,rc) <-
  72         case handler of
  73           Default -> do
  74             r <- rts_installHandler STG_SIG_DFL nullPtr
  75             return (no_handler, r)
  76           Ignore  -> do
  77             r <- rts_installHandler STG_SIG_IGN nullPtr
  78             return (no_handler, r)
  79           Catch h -> do
  80             r <- rts_installHandler STG_SIG_HAN nullPtr
  81             return (h, r)
  82       prev_handler <-
  83         case rc of
  84           STG_SIG_DFL -> return Default
  85           STG_SIG_IGN -> return Ignore
  86           STG_SIG_HAN -> return (Catch old_h)
  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   where
 109    fromConsoleEvent ev =
 110      case ev of
 111        ControlC -> 0 {- CTRL_C_EVENT-}
 112        Break    -> 1 {- CTRL_BREAK_EVENT-}
 113        Close    -> 2 {- CTRL_CLOSE_EVENT-}
 114        Logoff   -> 5 {- CTRL_LOGOFF_EVENT-}
 115        Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
 116
 117    toHandler hdlr ev = do
 118       case toWin32ConsoleEvent ev of
 119          -- see rts/win32/ConsoleHandler.c for comments as to why
 120          -- rts_ConsoleHandlerDone is called here.
 121         Just x  -> hdlr x >> rts_ConsoleHandlerDone ev
 122         Nothing -> return () -- silently ignore..
 123
 124    no_handler = error "win32ConsoleHandler"
 125
 126 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
 127
 128 foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
 129   rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
 130 foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
 131   rts_ConsoleHandlerDone :: CInt -> IO ()
 132
 133
 134 flushConsole :: Handle -> IO ()
 135 flushConsole h =
 136   wantReadableHandle "flushConsole" h $ \ h_ ->
 137      throwErrnoIfMinus1Retry_ "flushConsole"
 138       (flush_console_fd (fromIntegral (haFD h_)))
 139
 140 foreign import ccall unsafe "consUtils.h flush_input_console__"
 141         flush_console_fd :: CInt -> IO CInt
 142 #endif /* mingw32_HOST_OS */