GHC/ConsoleHandler.hs

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