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