X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConsoleHandler.hs;h=562ef32a675dea35d856c63fa483a825bc24addb;hb=7a97ec4b12e1fbec5505f82032cf4dc435b5a60c;hp=1654163eaea86adbcafc536aa7d817e5ff799015;hpb=7ae5d4712cba37e6484c40e5ca4525066db15339;p=ghc-base.git

diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs
index 1654163..562ef32 100644
--- a/GHC/ConsoleHandler.hs
+++ b/GHC/ConsoleHandler.hs
@@ -1,4 +1,5 @@
-{-# OPTIONS_GHC -cpp #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.ConsoleHandler
@@ -17,69 +18,102 @@
 
 module GHC.ConsoleHandler
 #if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__)
-	where
-import Prelude -- necessary to get dependencies right
+        where
 #else /* whole file */
-	( Handler(..)
-	, installHandler
-	, ConsoleEvent(..)
-	, flushConsole
-	) where
+        ( Handler(..)
+        , installHandler
+        , ConsoleEvent(..)
+        , flushConsole
+        ) where
 
 {-
-#include "Signals.h"
+#include "rts/Signals.h"
 -}
 
-import Prelude -- necessary to get dependencies right
-
 import Foreign
 import Foreign.C
-import GHC.IOBase
-import GHC.Handle
+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
+
+#ifdef mingw32_HOST_OS
+import Data.Maybe
+import GHC.Base
+#endif
 
 data Handler
  = Default
  | Ignore
  | Catch (ConsoleEvent -> IO ())
 
-data ConsoleEvent
- = ControlC
- | Break
- | Close
-    -- these are sent to Services only.
- | Logoff
- | Shutdown
-
+-- | 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 = 
+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 <- 
+   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
+        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)))
+         -- 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
-   toConsoleEvent ev = 
-     case ev of
-       0 {- CTRL_C_EVENT-}        -> Just ControlC
-       1 {- CTRL_BREAK_EVENT-}    -> Just Break
-       2 {- CTRL_CLOSE_EVENT-}    -> Just Close
-       5 {- CTRL_LOGOFF_EVENT-}   -> Just Logoff
-       6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown
-       _ -> Nothing
-   fromConsoleEvent ev = 
+   fromConsoleEvent ev =
      case ev of
        ControlC -> 0 {- CTRL_C_EVENT-}
        Break    -> 1 {- CTRL_BREAK_EVENT-}
@@ -88,11 +122,15 @@ installHandler handler =
        Shutdown -> 6 {- CTRL_SHUTDOWN_EVENT-}
 
    toHandler hdlr ev = do
-      case toConsoleEvent ev of
-	 -- see rts/win32/ConsoleHandler.c for comments as to why
-	 -- rts_ConsoleHandlerDone is called here.
+      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..
+        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
@@ -101,11 +139,17 @@ foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
 
 
 flushConsole :: Handle -> IO ()
-flushConsole h = 
-  wantReadableHandle "flushConsole" h $ \ h_ -> 
-     throwErrnoIfMinus1Retry_ "flushConsole"
-      (flush_console_fd (fromIntegral (haFD h_)))
+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
+        flush_console_fd :: CInt -> IO CInt
+
 #endif /* mingw32_HOST_OS */