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