GHC/ConsoleHandler.hs

    {-# LANGUAGE Trustworthy #-}
    {-# LANGUAGE CPP #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  GHC.ConsoleHandler
    -- Copyright   :  (c) The University of Glasgow
    -- License     :  see libraries/base/LICENSE
    --
    -- Maintainer  :  cvs-ghc@haskell.org
    -- Stability   :  internal
    -- Portability :  non-portable (GHC extensions)
    --
    -- NB. the contents of this module are only available on Windows.
    --
    -- Installing Win32 console handlers.
    --
    -----------------------------------------------------------------------------

    module GHC.ConsoleHandler
    #if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__)
            where
    #else /* whole file */
            ( Handler(..)
            , installHandler
            , ConsoleEvent(..)
            , flushConsole
            ) where

    {-
    #include "rts/Signals.h"

    Note: this #include is inside a Haskell comment
          but it brings into scope some #defines
          that are used by CPP below (eg STG_SIG_DFL).
          Having it in a comment means that there's no
          danger that C-like crap will be misunderstood
          by GHC
    -}

    import Foreign
    import Foreign.C
    import GHC.IO.FD
    import GHC.IO.Exception
    import GHC.IO.Handle.Types
    import GHC.IO.Handle.Internals
    import GHC.Conc
    import Control.Concurrent.MVar
    import Data.Typeable

    data Handler
     = Default
     | Ignore
     | Catch (ConsoleEvent -> IO ())

    -- | Allows Windows console events to be caught and handled.  To
    -- handle a console event, call 'installHandler' passing the
    -- appropriate 'Handler' value.  When the event is received, if the
    -- 'Handler' value is @Catch f@, then a new thread will be spawned by
    -- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that
    -- was received.
    --
    -- Note that console events can only be received by an application
    -- running in a Windows console.  Certain environments that look like consoles
    -- do not support console events, these include:
    --
    --  * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@,
    --    then a Cygwin shell behaves like a Windows console).
    --  * Cygwin xterm and rxvt windows
    --  * MSYS rxvt windows
    --
    -- In order for your application to receive console events, avoid running
    -- it in one of these environments.
    --
    installHandler :: Handler -> IO Handler
    installHandler handler
      | threaded =
        modifyMVar win32ConsoleHandler $ \old_h -> do
          (new_h,rc) <-
            case handler of
              Default -> do
                r <- rts_installHandler STG_SIG_DFL nullPtr
                return (no_handler, r)
              Ignore  -> do
                r <- rts_installHandler STG_SIG_IGN nullPtr
                return (no_handler, r)
              Catch h -> do
                r <- rts_installHandler STG_SIG_HAN nullPtr
                return (h, r)
          prev_handler <-
            case rc of
              STG_SIG_DFL -> return Default
              STG_SIG_IGN -> return Ignore
              STG_SIG_HAN -> return (Catch old_h)
              _           -> error "installHandler: Bad threaded rc value"
          return (new_h, prev_handler)

      | otherwise =
      alloca $ \ p_sp -> do
       rc <-
        case handler of
         Default -> rts_installHandler STG_SIG_DFL p_sp
         Ignore  -> rts_installHandler STG_SIG_IGN p_sp
         Catch h -> do
            v <- newStablePtr (toHandler h)
            poke p_sp v
            rts_installHandler STG_SIG_HAN p_sp
       case rc of
         STG_SIG_DFL -> return Default
         STG_SIG_IGN -> return Ignore
         STG_SIG_HAN -> do
            osptr <- peek p_sp
            oldh  <- deRefStablePtr osptr
             -- stable pointer is no longer in use, free it.
            freeStablePtr osptr
            return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
         _           -> error "installHandler: Bad non-threaded rc value"
      where
       fromConsoleEvent ev =
         case ev of
           ControlC -> 0 {- CTRL_C_EVENT-}
           Break    -> 1 {- CTRL_BREAK_EVENT-}
           Close    -> 2 {- CTRL_CLOSE_EVENT-}
           Logoff   -> 5 {- CTRL_LOGOFF_EVENT-}
           Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}

       toHandler hdlr ev = do
          case toWin32ConsoleEvent ev of
             -- see rts/win32/ConsoleHandler.c for comments as to why
             -- rts_ConsoleHandlerDone is called here.
            Just x  -> hdlr x >> rts_ConsoleHandlerDone ev
            Nothing -> return () -- silently ignore..

       no_handler = error "win32ConsoleHandler"

    foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool

    foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
      rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
    foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
      rts_ConsoleHandlerDone :: CInt -> IO ()

    flushConsole :: Handle -> IO ()
    flushConsole h =
      wantReadableHandle_ "flushConsole" h $ \ Handle__{haDevice=dev} ->
        case cast dev of
          Nothing -> ioException $
                        IOError (Just h) IllegalOperation "flushConsole"
                            "handle is not a file descriptor" Nothing Nothing
          Just fd -> do
            throwErrnoIfMinus1Retry_ "flushConsole" $
               flush_console_fd (fdFD fd)

    foreign import ccall unsafe "consUtils.h flush_input_console__"
            flush_console_fd :: CInt -> IO CInt

    #endif /* mingw32_HOST_OS */