GHC/ConsoleHandler.hs

   1 {-# OPTIONS -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 module GHC.ConsoleHandler
  16 #ifndef mingw32_TARGET_OS
  17         where
  18 #else /* whole file */
  19         ( Handler(..)
  20         , installHandler
  21         , ConsoleEvent(..)
  22         ) where
  23
  24 {-
  25 #include "Signals.h"
  26 -}
  27
  28 import Foreign
  29 import Foreign.C
  30
  31 data Handler
  32  = Default
  33  | Ignore
  34  | Catch (ConsoleEvent -> IO ())
  35
  36 data ConsoleEvent
  37  = ControlC
  38  | Break
  39  | Close
  40     -- these are sent to Services only.
  41  | Logoff
  42  | Shutdown
  43
  44 installHandler :: Handler -> IO Handler
  45 installHandler handler =
  46   alloca $ \ p_sp -> do
  47    rc <-
  48     case handler of
  49      Default -> rts_installHandler STG_SIG_DFL p_sp
  50      Ignore  -> rts_installHandler STG_SIG_IGN p_sp
  51      Catch h -> do
  52         v <- newStablePtr (toHandler h)
  53         poke p_sp v
  54         rts_installHandler STG_SIG_HAN p_sp
  55    case rc of
  56      STG_SIG_DFL -> return Default
  57      STG_SIG_IGN -> return Ignore
  58      STG_SIG_HAN -> do
  59         osptr <- peek p_sp
  60         oldh  <- deRefStablePtr osptr
  61          -- stable pointer is no longer in use, free it.
  62         freeStablePtr osptr
  63         return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
  64   where
  65    toConsoleEvent ev =
  66      case ev of
  67        0 {- CTRL_C_EVENT-}        -> Just ControlC
  68        1 {- CTRL_BREAK_EVENT-}    -> Just Break
  69        2 {- CTRL_CLOSE_EVENT-}    -> Just Close
  70        5 {- CTRL_LOGOFF_EVENT-}   -> Just Logoff
  71        6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
  72        _ -> Nothing
  73    fromConsoleEvent ev =
  74      case ev of
  75        ControlC -> 0 {- CTRL_C_EVENT-}
  76        Break    -> 1 {- CTRL_BREAK_EVENT-}
  77        Close    -> 2 {- CTRL_CLOSE_EVENT-}
  78        Logoff   -> 5 {- CTRL_LOGOFF_EVENT-}
  79        Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
  80
  81    toHandler hdlr ev = do
  82       case toConsoleEvent ev of
  83         Just x  -> hdlr x
  84         Nothing -> return () -- silently ignore..
  85
  86 foreign import ccall unsafe "Signals.h stg_InstallConsoleEvent"
  87   rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
  88 #endif /* mingw32_TARGET_OS */