GHC/ConsoleHandler.hs

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