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 "rts/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 #ifdef mingw32_HOST_OS
  43 import Data.Maybe
  44 import GHC.Base
  45 import GHC.Num
  46 import GHC.Real
  47 #endif
  48
  49 data Handler
  50  = Default
  51  | Ignore
  52  | Catch (ConsoleEvent -> IO ())
  53
  54 -- | Allows Windows console events to be caught and handled.  To
  55 -- handle a console event, call 'installHandler' passing the
  56 -- appropriate 'Handler' value.  When the event is received, if the
  57 -- 'Handler' value is @Catch f@, then a new thread will be spawned by
  58 -- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that
  59 -- was received.
  60 --
  61 -- Note that console events can only be received by an application
  62 -- running in a Windows console.  Certain environments that look like consoles
  63 -- do not support console events, these include:
  64 --
  65 --  * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@,
  66 --    then a Cygwin shell behaves like a Windows console).
  67 --  * Cygwin xterm and rxvt windows
  68 --  * MSYS rxvt windows
  69 --
  70 -- In order for your application to receive console events, avoid running
  71 -- it in one of these environments.
  72 --
  73 installHandler :: Handler -> IO Handler
  74 installHandler handler
  75   | threaded =
  76     modifyMVar win32ConsoleHandler $ \old_h -> do
  77       (new_h,rc) <-
  78         case handler of
  79           Default -> do
  80             r <- rts_installHandler STG_SIG_DFL nullPtr
  81             return (no_handler, r)
  82           Ignore  -> do
  83             r <- rts_installHandler STG_SIG_IGN nullPtr
  84             return (no_handler, r)
  85           Catch h -> do
  86             r <- rts_installHandler STG_SIG_HAN nullPtr
  87             return (h, r)
  88       prev_handler <-
  89         case rc of
  90           STG_SIG_DFL -> return Default
  91           STG_SIG_IGN -> return Ignore
  92           STG_SIG_HAN -> return (Catch old_h)
  93           _           -> error "installHandler: Bad threaded rc value"
  94       return (new_h, prev_handler)
  95
  96   | otherwise =
  97   alloca $ \ p_sp -> do
  98    rc <-
  99     case handler of
 100      Default -> rts_installHandler STG_SIG_DFL p_sp
 101      Ignore  -> rts_installHandler STG_SIG_IGN p_sp
 102      Catch h -> do
 103         v <- newStablePtr (toHandler h)
 104         poke p_sp v
 105         rts_installHandler STG_SIG_HAN p_sp
 106    case rc of
 107      STG_SIG_DFL -> return Default
 108      STG_SIG_IGN -> return Ignore
 109      STG_SIG_HAN -> do
 110         osptr <- peek p_sp
 111         oldh  <- deRefStablePtr osptr
 112          -- stable pointer is no longer in use, free it.
 113         freeStablePtr osptr
 114         return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
 115      _           -> error "installHandler: Bad non-threaded rc value"
 116   where
 117    fromConsoleEvent ev =
 118      case ev of
 119        ControlC -> 0 {- CTRL_C_EVENT-}
 120        Break    -> 1 {- CTRL_BREAK_EVENT-}
 121        Close    -> 2 {- CTRL_CLOSE_EVENT-}
 122        Logoff   -> 5 {- CTRL_LOGOFF_EVENT-}
 123        Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
 124
 125    toHandler hdlr ev = do
 126       case toWin32ConsoleEvent ev of
 127          -- see rts/win32/ConsoleHandler.c for comments as to why
 128          -- rts_ConsoleHandlerDone is called here.
 129         Just x  -> hdlr x >> rts_ConsoleHandlerDone ev
 130         Nothing -> return () -- silently ignore..
 131
 132    no_handler = error "win32ConsoleHandler"
 133
 134 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
 135
 136 foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
 137   rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
 138 foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
 139   rts_ConsoleHandlerDone :: CInt -> IO ()
 140
 141
 142 flushConsole :: Handle -> IO ()
 143 flushConsole h =
 144   wantReadableHandle_ "flushConsole" h $ \ Handle__{haDevice=dev} ->
 145     case cast dev of
 146       Nothing -> ioException $
 147                     IOError (Just h) IllegalOperation "flushConsole"
 148                         "handle is not a file descriptor" Nothing Nothing
 149       Just fd -> do
 150         throwErrnoIfMinus1Retry_ "flushConsole" $
 151            flush_console_fd (fromIntegral (fdFD fd))
 152
 153 foreign import ccall unsafe "consUtils.h flush_input_console__"
 154         flush_console_fd :: CInt -> IO CInt
 155
 156 #endif /* mingw32_HOST_OS */