Haskell Code by HsColour

{-# OPTIONS_GHC -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
import Prelude -- necessary to get dependencies right
#else /* whole file */
 ( Handler(..)
 , installHandler
 , ConsoleEvent(..)
 , flushConsole
 ) where

{-
#include "Signals.h"
-}

import Prelude -- necessary to get dependencies right

import Foreign
import Foreign.C
import GHC.IOBase
import GHC.Conc
import GHC.Handle
import Control.Exception (onException)

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 $ \ h_ ->
 throwErrnoIfMinus1Retry_ "flushConsole"
 (flush_console_fd (fromIntegral (haFD h_)))

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

-- XXX Copied from Control.Concurrent.MVar
modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m io =
 block $ do
 a <- takeMVar m
 (a',b) <- unblock (io a) `onException` putMVar m a
 putMVar m a'
 return b
#endif /* mingw32_HOST_OS */