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