Repository : ssh://darcs.haskell.org//srv/darcs/packages/haskeline On branch : master
http://hackage.haskell.org/trac/ghc/changeset/441b41485bd89a7a99f047b1aa38094a8cd00ef5 >--------------------------------------------------------------- commit 441b41485bd89a7a99f047b1aa38094a8cd00ef5 Author: Judah Jacobson <[email protected]> Date: Sun Oct 16 23:38:24 2011 +0000 Fix #73, again. (Pasting multiple lines might drop some characters.) I think the regression occured when I fixed #106. >--------------------------------------------------------------- System/Console/Haskeline/Backend/DumbTerm.hs | 1 + System/Console/Haskeline/Backend/Terminfo.hs | 1 + System/Console/Haskeline/Backend/Win32.hsc | 1 + System/Console/Haskeline/RunCommand.hs | 22 +++++++++++++--------- System/Console/Haskeline/Term.hs | 3 +++ 5 files changed, 19 insertions(+), 9 deletions(-) diff --git a/System/Console/Haskeline/Backend/DumbTerm.hs b/System/Console/Haskeline/Backend/DumbTerm.hs index 47cd138..f92301e 100644 --- a/System/Console/Haskeline/Backend/DumbTerm.hs +++ b/System/Console/Haskeline/Backend/DumbTerm.hs @@ -38,6 +38,7 @@ runDumbTerm h = do TermOps { getLayout = tryGetLayouts (posixLayouts h) , withGetEvent = withPosixGetEvent ch h enc [] + , saveUnusedKeys = saveKeys ch , runTerm = \(RunTermType f) -> runPosixT enc h $ evalStateT' initWindow diff --git a/System/Console/Haskeline/Backend/Terminfo.hs b/System/Console/Haskeline/Backend/Terminfo.hs index 0e9582a..20eeac3 100644 --- a/System/Console/Haskeline/Backend/Terminfo.hs +++ b/System/Console/Haskeline/Backend/Terminfo.hs @@ -153,6 +153,7 @@ runTerminfoDraw h = do , withGetEvent = wrapKeypad (hOut h) term . withPosixGetEvent ch h enc (terminfoKeys term) + , saveUnusedKeys = saveKeys ch , runTerm = \(RunTermType f) -> runPosixT enc h $ evalStateT' initTermPos diff --git a/System/Console/Haskeline/Backend/Win32.hsc b/System/Console/Haskeline/Backend/Win32.hsc index bdc7bab..d66a805 100644 --- a/System/Console/Haskeline/Backend/Win32.hsc +++ b/System/Console/Haskeline/Backend/Win32.hsc @@ -360,6 +360,7 @@ win32Term = do getLayout = getBufferSize (hOut hs) , withGetEvent = withWindowMode hs . win32WithEvent hs ch + , saveUnusedKeys = saveKeys ch , runTerm = \(RunTermType f) -> runReaderT' hs $ runDraw f }, diff --git a/System/Console/Haskeline/RunCommand.hs b/System/Console/Haskeline/RunCommand.hs index 6a81f8d..d499bbd 100644 --- a/System/Console/Haskeline/RunCommand.hs +++ b/System/Console/Haskeline/RunCommand.hs @@ -22,9 +22,9 @@ runCommandLoop' :: forall t m s a . (MonadTrans t, Term (t m), CommandMonad (t m runCommandLoop' tops prefix initState cmds getEvent = do let s = lineChars prefix initState drawLine s - readMoreKeys s (fmap ($ initState) cmds) + readMoreKeys s (fmap (liftM (\x -> (x,[])) . ($ initState)) cmds) where - readMoreKeys :: LineChars -> KeyMap (CmdM m a) -> t m a + readMoreKeys :: LineChars -> KeyMap (CmdM m (a,[Key])) -> t m a readMoreKeys s next = do event <- handle (\(e::SomeException) -> moveToNextLine s >> throwIO e) getEvent @@ -36,7 +36,7 @@ runCommandLoop' tops prefix initState cmds getEvent = do bound_ks <- mapM (lift . asks . lookupKeyBinding) ks loopCmd s $ applyKeysToMap (concat bound_ks) next - loopCmd :: LineChars -> CmdM m a -> t m a + loopCmd :: LineChars -> CmdM m (a,[Key]) -> t m a loopCmd s (GetKey next) = readMoreKeys s next -- If there are multiple consecutive LineChanges, only render the diff -- to the last one, and skip the rest. This greatly improves speed when @@ -47,7 +47,10 @@ runCommandLoop' tops prefix initState cmds getEvent = do t <- drawEffect prefix s e loopCmd t next loopCmd s (CmdM next) = lift next >>= loopCmd s - loopCmd s (Result x) = moveToNextLine s >> return x + loopCmd s (Result (x,ks)) = do + liftIO (saveUnusedKeys tops ks) + moveToNextLine s + return x drawEffect :: (MonadTrans t, Term (t m), MonadReader Prefs m) @@ -89,17 +92,18 @@ drawReposition tops s = do --------------- -- Traverse through the tree of keybindings, using the given keys. -- Remove as many GetKeys as possible. -applyKeysToMap :: Monad m => [Key] -> KeyMap (CmdM m a) - -> CmdM m a +-- Returns any unused keys (so that they can be applied at the next getInputLine). +applyKeysToMap :: Monad m => [Key] -> KeyMap (CmdM m (a,[Key])) + -> CmdM m (a,[Key]) applyKeysToMap [] next = GetKey next applyKeysToMap (k:ks) next = case lookupKM next k of Nothing -> DoEffect RingBell $ GetKey next Just (Consumed cmd) -> applyKeysToCmd ks cmd Just (NotConsumed cmd) -> applyKeysToCmd (k:ks) cmd -applyKeysToCmd :: Monad m => [Key] -> CmdM m a - -> CmdM m a +applyKeysToCmd :: Monad m => [Key] -> CmdM m (a,[Key]) + -> CmdM m (a,[Key]) applyKeysToCmd ks (GetKey next) = applyKeysToMap ks next applyKeysToCmd ks (DoEffect e next) = DoEffect e (applyKeysToCmd ks next) applyKeysToCmd ks (CmdM next) = CmdM $ liftM (applyKeysToCmd ks) next -applyKeysToCmd _ (Result x) = Result x +applyKeysToCmd ks (Result (x,ys)) = Result (x,ys++ks) -- use in the next input line diff --git a/System/Console/Haskeline/Term.hs b/System/Console/Haskeline/Term.hs index 0387878..3ba6ef5 100644 --- a/System/Console/Haskeline/Term.hs +++ b/System/Console/Haskeline/Term.hs @@ -45,6 +45,7 @@ data TermOps = TermOps { , withGetEvent :: (MonadException m, CommandMonad m) => (m Event -> m a) -> m a , runTerm :: (MonadException m, CommandMonad m) => RunTermType m a -> m a + , saveUnusedKeys :: [Key] -> IO () } -- | Operations needed for file-style interaction. @@ -112,6 +113,8 @@ keyEventLoop readEvents eventChan = do Just ThreadKilled -> return () _ -> writeChan eventChan (ErrorEvent e) +saveKeys :: Chan Event -> [Key] -> IO () +saveKeys ch = writeChan ch . KeyInput data Interrupt = Interrupt deriving (Show,Typeable,Eq) _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
