[commit: haskeline] master: Add back wrap/handleInterrupt. (62fac92)

[Paolo Capriotti]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/haskeline

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/62fac92e4629982cc1dd8ee95d3915be5016e5b3

>---------------------------------------------------------------

commit 62fac92e4629982cc1dd8ee95d3915be5016e5b3
Author: Judah Jacobson <judah.jacobson at gmail.com>
Date:   Tue Jul 17 18:53:00 2012 +0000

    Add back wrap/handleInterrupt.
    
    Although GHC provides similar functionality by default, it will
    terminate the program the second time that ctrl-c is pressed.  In contrast,
    wrapInterrupt will throw an exception on every ctrl-c, which is better
    behavior for the types of programs that use haskeline.

>---------------------------------------------------------------

 System/Console/Haskeline.hs                |   35 ++++++++++++++++++++++++++++
 System/Console/Haskeline/Backend/Posix.hsc |   10 +++++++-
 System/Console/Haskeline/Backend/Win32.hsc |   26 ++++++++++++++++++++
 System/Console/Haskeline/Term.hs           |    9 +++++++
 examples/Test.hs                           |    4 +-
 5 files changed, 81 insertions(+), 3 deletions(-)

diff --git a/System/Console/Haskeline.hs b/System/Console/Haskeline.hs
index 8878ff4..91ca817 100644
--- a/System/Console/Haskeline.hs
+++ b/System/Console/Haskeline.hs
@@ -67,6 +67,10 @@ module System.Console.Haskeline(
                     getHistory,
                     putHistory,
                     modifyHistory,
+                    -- * Ctrl-C handling
+                    withInterrupt,
+                    Interrupt(..),
+                    handleInterrupt,
                     -- * Additional submodules
                     module System.Console.Haskeline.Completion,
                     module System.Console.Haskeline.MonadException)
@@ -281,3 +285,34 @@ promptedInput doTerm doFile prompt = do
             let (lastLine,rest) = break (`elem` "\r\n") $ reverse prompt
             outputStr $ reverse rest
             doTerm tops $ reverse lastLine
+
+{- | If Ctrl-C is pressed during the given action, throw an exception
+of type 'Interrupt'.  For example:
+
+> tryAction :: InputT IO ()
+> tryAction = handle (\Interrupt -> outputStrLn "Cancelled.")
+>                $ wrapInterrupt $ someLongAction
+
+The action can handle the interrupt itself; a new 'Interrupt' exception will be thrown
+every time Ctrl-C is pressed.
+
+> tryAction :: InputT IO ()
+> tryAction = wrapInterrupt loop
+>     where loop = handle (\Interrupt -> outputStrLn "Cancelled; try again." >> loop)
+>                    someLongAction
+ 
+This behavior differs from GHC's built-in Ctrl-C handling, which
+may immediately terminate the program after the second time that the user presses
+Ctrl-C.
+
+-}
+withInterrupt :: MonadException m => InputT m a -> InputT m a
+withInterrupt act = do
+    rterm <- InputT ask
+    liftIOOp_ (wrapInterrupt rterm) act
+
+-- | Catch and handle an exception of type 'Interrupt'.  
+--
+-- > handleInterrupt f = handle $ \Interrupt -> f
+handleInterrupt :: MonadException m => m a -> m a -> m a
+handleInterrupt f = handle $ \Interrupt -> f
diff --git a/System/Console/Haskeline/Backend/Posix.hsc b/System/Console/Haskeline/Backend/Posix.hsc
index 1ea2897..4ffbf53 100644
--- a/System/Console/Haskeline/Backend/Posix.hsc
+++ b/System/Console/Haskeline/Backend/Posix.hsc
@@ -17,7 +17,7 @@ module System.Console.Haskeline.Backend.Posix (
 import Foreign
 import Foreign.C.Types
 import qualified Data.Map as Map
-import System.Posix.Terminal
+import System.Posix.Terminal hiding (Interrupt)
 import Control.Monad
 import Control.Concurrent hiding (throwTo)
 import Data.Maybe (catMaybes)
@@ -220,6 +220,13 @@ withWindowHandler :: MonadException m => Chan Event -> m a -> m a
 withWindowHandler eventChan = withHandler windowChange $ 
     Catch $ writeChan eventChan WindowResize
 
+withSigIntHandler :: MonadException m => m a -> m a
+withSigIntHandler f = do
+    tid <- liftIO myThreadId 
+    withHandler keyboardSignal 
+            (Catch (throwTo tid Interrupt))
+            f
+
 withHandler :: MonadException m => Signal -> Handler -> m a -> m a
 withHandler signal handler f = do
     old_handler <- liftIO $ installHandler signal handler Nothing
@@ -353,6 +360,7 @@ fileRunTerm h_in = do
     decoder' <- openPartialDecoder codeset
     return RunTerm {putStrOut = encoder >=> putTerm h_out,
                 closeTerm = setLocale oldLocale >> return (),
+                wrapInterrupt = withSigIntHandler,
                 termOps = Right FileOps {
                             inputHandle = h_in,
                             getLocaleChar = getMultiByteChar h_in decoder',
diff --git a/System/Console/Haskeline/Backend/Win32.hsc b/System/Console/Haskeline/Backend/Win32.hsc
index 97e5782..d6cb56e 100644
--- a/System/Console/Haskeline/Backend/Win32.hsc
+++ b/System/Console/Haskeline/Backend/Win32.hsc
@@ -391,6 +391,7 @@ fileRunTerm h_in = do
     return RunTerm {
                     closeTerm = return (),
                     putStrOut = putter,
+                    wrapInterrupt = withCtrlCHandler,
                     termOps = Right FileOps {
                                 inputHandle = h_in,
                                 getLocaleChar = getMultiByteChar cp h_in,
@@ -415,6 +416,31 @@ putOut = do
             return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout
 
 
+type Handler = DWORD -> IO BOOL
+
+foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler)
+
+foreign import stdcall "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler
+    :: FunPtr Handler -> BOOL -> IO BOOL
+
+-- sets the tv to True when ctrl-c is pressed.
+withCtrlCHandler :: MonadException m => m a -> m a
+withCtrlCHandler f = bracket (liftIO $ do
+                                    tid <- myThreadId
+                                    fp <- wrapHandler (handler tid)
+                                -- don't fail if we can't set the ctrl-c handler
+                                -- for example, we might not be attached to a console?
+                                    _ <- c_SetConsoleCtrlHandler fp True
+                                    return fp)
+                                (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False)
+                                (const f)
+  where
+    handler tid (#const CTRL_C_EVENT) = do
+        throwTo tid Interrupt
+        return True
+    handler _ _ = return False
+
+
 
 ------------------------
 -- Multi-byte conversion
diff --git a/System/Console/Haskeline/Term.hs b/System/Console/Haskeline/Term.hs
index e622199..a65204e 100644
--- a/System/Console/Haskeline/Term.hs
+++ b/System/Console/Haskeline/Term.hs
@@ -11,6 +11,7 @@ import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Word
 import Control.Exception (fromException, AsyncException(..),bracket_)
+import Data.Typeable
 import System.IO
 import Control.Monad(liftM,when,guard)
 import System.IO.Error (isEOFError)
@@ -32,6 +33,7 @@ data RunTerm = RunTerm {
             -- | Write unicode characters to stdout.
             putStrOut :: String -> IO (),
             termOps :: Either TermOps FileOps,
+            wrapInterrupt :: forall a . IO a -> IO a,            
             closeTerm :: IO ()
     }
 
@@ -68,6 +70,13 @@ mapEvalTerm :: (forall a . n a -> m a) -> (forall a . m a -> n a)
 mapEvalTerm eval liftE (EvalTerm eval' liftE')
     = EvalTerm (eval . eval') (liftE' . liftE)
 
+data Interrupt = Interrupt
+                deriving (Show,Typeable,Eq)
+
+instance Exception Interrupt where
+
+
+
 class (MonadReader Prefs m , MonadReader Layout m, MonadException m)
         => CommandMonad m where
     runCompletion :: (String,String) -> m (String,[Completion])
diff --git a/examples/Test.hs b/examples/Test.hs
index bbe1f02..7b25c7b 100644
--- a/examples/Test.hs
+++ b/examples/Test.hs
@@ -27,10 +27,10 @@ main = do
                 ["password", [c]] -> getPassword (Just c)
                 ["initial"] -> flip getInputLineWithInitial ("left ", "right")
                 _ -> getInputLine
-        runInputT mySettings $ loop inputFunc 0
+        runInputT mySettings $ withInterrupt $ loop inputFunc 0
     where
         loop inputFunc n = do
-            minput <-  handle (\UserInterrupt -> return (Just "Caught interrupted"))
+            minput <-  handle (\Interrupt -> return (Just "Caught interrupted"))
                         $ inputFunc (show n ++ ":")
             case minput of
                 Nothing -> return ()