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 import Data.Typeable
  40
  41 data Handler
  42  = Default
  43  | Ignore
  44  | Catch (ConsoleEvent -> IO ())
  45
  46 data ConsoleEvent
  47  = ControlC
  48  | Break
  49  | Close
  50     -- these are sent to Services only.
  51  | Logoff
  52  | Shutdown
  53  deriving (Eq, Ord, Enum, Show, Read, Typeable)
  54
  55 installHandler :: Handler -> IO Handler
  56 installHandler handler =
  57   alloca $ \ p_sp -> do
  58    rc <-
  59     case handler of
  60      Default -> rts_installHandler STG_SIG_DFL p_sp
  61      Ignore  -> rts_installHandler STG_SIG_IGN p_sp
  62      Catch h -> do
  63         v <- newStablePtr (toHandler h)
  64         poke p_sp v
  65         rts_installHandler STG_SIG_HAN p_sp
  66    case rc of
  67      STG_SIG_DFL -> return Default
  68      STG_SIG_IGN -> return Ignore
  69      STG_SIG_HAN -> do
  70         osptr <- peek p_sp
  71         oldh  <- deRefStablePtr osptr
  72          -- stable pointer is no longer in use, free it.
  73         freeStablePtr osptr
  74         return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
  75   where
  76    toConsoleEvent ev =
  77      case ev of
  78        0 {- CTRL_C_EVENT-}        -> Just ControlC
  79        1 {- CTRL_BREAK_EVENT-}    -> Just Break
  80        2 {- CTRL_CLOSE_EVENT-}    -> Just Close
  81        5 {- CTRL_LOGOFF_EVENT-}   -> Just Logoff
  82        6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
  83        _ -> Nothing
  84    fromConsoleEvent ev =
  85      case ev of
  86        ControlC -> 0 {- CTRL_C_EVENT-}
  87        Break    -> 1 {- CTRL_BREAK_EVENT-}
  88        Close    -> 2 {- CTRL_CLOSE_EVENT-}
  89        Logoff   -> 5 {- CTRL_LOGOFF_EVENT-}
  90        Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
  91
  92    toHandler hdlr ev = do
  93       case toConsoleEvent ev of
  94          -- see rts/win32/ConsoleHandler.c for comments as to why
  95          -- rts_ConsoleHandlerDone is called here.
  96         Just x  -> hdlr x >> rts_ConsoleHandlerDone ev
  97         Nothing -> return () -- silently ignore..
  98
  99 foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
 100   rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
 101 foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
 102   rts_ConsoleHandlerDone :: CInt -> IO ()
 103
 104
 105 flushConsole :: Handle -> IO ()
 106 flushConsole h =
 107   wantReadableHandle "flushConsole" h $ \ h_ ->
 108      throwErrnoIfMinus1Retry_ "flushConsole"
 109       (flush_console_fd (fromIntegral (haFD h_)))
 110
 111 foreign import ccall unsafe "consUtils.h flush_input_console__"
 112         flush_console_fd :: CInt -> IO CInt
 113 #endif /* mingw32_HOST_OS */