GHC/ConsoleHandler.hs

   1 {-# OPTIONS_GHC -cpp #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  GHC.ConsoleHandler
   5 -- Copyright   :  whatevah
   6 -- License     :  see libraries/base/LICENSE
   7 --
   8 -- Maintainer  :  cvs-ghc@haskell.org
   9 -- Stability   :  internal
  10 -- Portability :  non-portable (GHC extensions)
  11 --
  12 -- Installing Win32 console handlers.
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module GHC.ConsoleHandler
  17 #ifndef mingw32_HOST_OS
  18         where
  19 import Prelude -- necessary to get dependencies right
  20 #else /* whole file */
  21         ( Handler(..)
  22         , installHandler
  23         , ConsoleEvent(..)
  24         , flushConsole
  25         ) where
  26
  27 {-
  28 #include "Signals.h"
  29 -}
  30
  31 import Prelude -- necessary to get dependencies right
  32
  33 import Foreign
  34 import Foreign.C
  35 import GHC.IOBase
  36 import GHC.Handle
  37
  38 data Handler
  39  = Default
  40  | Ignore
  41  | Catch (ConsoleEvent -> IO ())
  42
  43 data ConsoleEvent
  44  = ControlC
  45  | Break
  46  | Close
  47     -- these are sent to Services only.
  48  | Logoff
  49  | Shutdown
  50
  51 installHandler :: Handler -> IO Handler
  52 installHandler handler =
  53   alloca $ \ p_sp -> do
  54    rc <-
  55     case handler of
  56      Default -> rts_installHandler STG_SIG_DFL p_sp
  57      Ignore  -> rts_installHandler STG_SIG_IGN p_sp
  58      Catch h -> do
  59         v <- newStablePtr (toHandler h)
  60         poke p_sp v
  61         rts_installHandler STG_SIG_HAN p_sp
  62    case rc of
  63      STG_SIG_DFL -> return Default
  64      STG_SIG_IGN -> return Ignore
  65      STG_SIG_HAN -> do
  66         osptr <- peek p_sp
  67         oldh  <- deRefStablePtr osptr
  68          -- stable pointer is no longer in use, free it.
  69         freeStablePtr osptr
  70         return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
  71   where
  72    toConsoleEvent ev =
  73      case ev of
  74        0 {- CTRL_C_EVENT-}        -> Just ControlC
  75        1 {- CTRL_BREAK_EVENT-}    -> Just Break
  76        2 {- CTRL_CLOSE_EVENT-}    -> Just Close
  77        5 {- CTRL_LOGOFF_EVENT-}   -> Just Logoff
  78        6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
  79        _ -> Nothing
  80    fromConsoleEvent ev =
  81      case ev of
  82        ControlC -> 0 {- CTRL_C_EVENT-}
  83        Break    -> 1 {- CTRL_BREAK_EVENT-}
  84        Close    -> 2 {- CTRL_CLOSE_EVENT-}
  85        Logoff   -> 5 {- CTRL_LOGOFF_EVENT-}
  86        Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
  87
  88    toHandler hdlr ev = do
  89       case toConsoleEvent ev of
  90          -- see rts/win32/ConsoleHandler.c for comments as to why
  91          -- rts_ConsoleHandlerDone is called here.
  92         Just x  -> hdlr x >> rts_ConsoleHandlerDone ev
  93         Nothing -> return () -- silently ignore..
  94
  95 foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
  96   rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
  97 foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
  98   rts_ConsoleHandlerDone :: CInt -> IO ()
  99
 100
 101 flushConsole :: Handle -> IO ()
 102 flushConsole h =
 103   wantReadableHandle "flushConsole" h $ \ h_ ->
 104      throwErrnoIfMinus1Retry_ "flushConsole"
 105       (flush_console_fd (fromIntegral (haFD h_)))
 106
 107 foreign import ccall unsafe "consUtils.h flush_input_console__"
 108         flush_console_fd :: CInt -> IO CInt
 109 #endif /* mingw32_HOST_OS */