haskeline 0.4 → 0.5

raw patch · 21 files changed

+804/−316 lines, 21 filesdep ~basedep ~bytestringdep ~extensible-exceptionsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, bytestring, extensible-exceptions, filepath, mtl, stm, terminfo, unix, utf8-string

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• System/Console/Haskeline.hs +119/−43
• System/Console/Haskeline/Backend/DumbTerm.hs +0/−1
• System/Console/Haskeline/Backend/Posix.hsc +46/−33
• System/Console/Haskeline/Backend/Terminfo.hs +1/−2
• System/Console/Haskeline/Backend/Win32.hsc +88/−37
• System/Console/Haskeline/Command.hs +11/−22
• System/Console/Haskeline/Command/Completion.hs +9/−6
• System/Console/Haskeline/Command/History.hs +9/−30
• System/Console/Haskeline/Command/Undo.hs +1/−0
• System/Console/Haskeline/Completion.hs +12/−8
• System/Console/Haskeline/Emacs.hs +24/−24
• System/Console/Haskeline/History.hs +90/−0
• System/Console/Haskeline/IO.hs +102/−0
• System/Console/Haskeline/InputT.hs +15/−6
• System/Console/Haskeline/Key.hs +119/−0
• System/Console/Haskeline/Prefs.hs +53/−33
• System/Console/Haskeline/Term.hs +16/−5
• System/Console/Haskeline/Vi.hs +58/−54
• examples/Test.hs +19/−5
• haskeline.cabal +11/−6

@@ -1,4 +1,4 @@-Copyright 2007, Judah Jacobson.+Copyright 2007-2008, Judah Jacobson. All Rights Reserved.  Redistribution and use in source and binary forms, with or without

@@ -3,8 +3,8 @@ A rich user interface for line input in command-line programs.  Haskeline is Unicode-aware and runs both on POSIX-compatible systems and on Windows.   -Users may customize the interface with a @~/.haskeline@ file; see the-"System.Console.Haskeline.Prefs" module for more details.+Users may customize the interface with a @~/.haskeline@ file; see+<http://trac.haskell.org/haskeline/wiki/UserPrefs> for more information.  An example use of this library for a simple read-eval-print loop is the following:@@ -23,50 +23,58 @@ >                Just input -> do outputStrLn $ "Input was: " ++ input >                                 loop -If either 'stdin' or 'stdout' is not connected to a terminal (for example, piped from another-process), Haskeline will treat it as a UTF-8-encoded file handle.  - -}   module System.Console.Haskeline(                     -- * Main functions+                    -- ** The InputT monad transformer                     InputT,                     runInputT,                     runInputTWithPrefs,+                    -- ** Reading user input+                    -- $inputfncs                     getInputLine,+                    getInputChar,+                    -- ** Outputting text+                    -- $outputfncs                     outputStr,                     outputStrLn,                     -- * Settings                     Settings(..),                     defaultSettings,                     setComplete,+                    -- * User preferences+                    Prefs(),+                    readPrefs,+                    defaultPrefs,                     -- * Ctrl-C handling                     -- $ctrlc                     Interrupt(..),                     withInterrupt,                     handleInterrupt,                     module System.Console.Haskeline.Completion,-                    module System.Console.Haskeline.Prefs,                     module System.Console.Haskeline.MonadException)                      where  import System.Console.Haskeline.LineState import System.Console.Haskeline.Command-import System.Console.Haskeline.Command.History import System.Console.Haskeline.Vi import System.Console.Haskeline.Emacs import System.Console.Haskeline.Prefs+import System.Console.Haskeline.History import System.Console.Haskeline.Monads import System.Console.Haskeline.MonadException import System.Console.Haskeline.InputT import System.Console.Haskeline.Completion import System.Console.Haskeline.Term+import System.Console.Haskeline.Key  import System.IO import qualified System.IO.UTF8 as UTF8 import Data.Char (isSpace) import Control.Monad+import Data.Char(isPrint)   @@ -77,35 +85,55 @@ -- defaultSettings = Settings { --           complete = completeFilename, --           historyFile = Nothing,+--           autoAddHistory = True --           } -- @ defaultSettings :: MonadIO m => Settings m defaultSettings = Settings {complete = completeFilename,-                        historyFile = Nothing}+                        historyFile = Nothing,+                        autoAddHistory = True} --- | Write a string to the standard output.  Allows cross-platform display of Unicode--- characters.+{- $outputfncs+The following functions allow cross-platform output of text that may contain+Unicode characters.++If 'stdout' is not connected to a terminal (for example,+piped to another process), Haskeline will treat it as a UTF-8-encoded file+handle.+-}++-- | Write a string to the standard output. outputStr :: MonadIO m => String -> InputT m () outputStr xs = do     putter <- asks putStrOut     liftIO $ putter xs --- | Write a string to the standard output, followed by a newline.  Allows--- cross-platform display of Unicode characters.+-- | Write a string to the standard output, followed by a newline. outputStrLn :: MonadIO m => String -> InputT m () outputStrLn xs = outputStr (xs++"\n") -{- | Read one line of input.  The final newline (if any) is removed. -If 'stdin' is connected to a terminal with echoing enabled, 'getInputLine' provides a rich line-editing-user interface.  It returns 'Nothing' if the user presses @Ctrl-D@ when the input-text is empty.  All user interaction, including display of the input prompt, will occur-on the user's output terminal (which may differ from 'stdout').+{- $inputfncs+The following functions read one line or character of input from the user. -If 'stdin' is not connected to a terminal, 'getInputLine' prints the prompt to 'stdout'-and reads one line of input. It returns 'Nothing'  if an @EOF@ is-encountered before any characters are read.+If 'stdin' is connected to a terminal, then these functions perform all user interaction,+including display of the prompt text, on the user's output terminal (which may differ from+'stdout').+They return 'Nothing' if the user pressed @Ctrl-D@ when the+input text was empty.++If 'stdin' is not connected to a terminal or does not have echoing enabled, it will be+treated as a UTF8-encoded file handle.  These functions print the prompt to 'stdout',+and they return 'Nothing' if an @EOF@ was encountered before any characters were read. -}+++{- | Reads one line of input.  The final newline (if any) is removed.  Provides a rich+line-editing user interface if 'stdin' is a terminal.++If @'autoAddHistory' == 'True'@ and the line input is nonblank (i.e., is not all+spaces), it will be automatically added to the history.+-} getInputLine :: forall m . MonadException m => String -- ^ The input prompt                             -> InputT m (Maybe String) getInputLine prefix = do@@ -131,12 +159,17 @@                             let ls = emptyIM                             drawLine prefix ls                              repeatTillFinish tops getEvent prefix ls emode-    -- Add the line to the history if it's nonempty.-    case result of -        Just line | not (all isSpace line) -> addHistory line-        _ -> return ()+    maybeAddHistory result     return result +maybeAddHistory :: forall m . Monad m => Maybe String -> InputT m ()+maybeAddHistory result = do+    settings :: Settings m <- ask+    case result of+        Just line | autoAddHistory settings && not (all isSpace line) +            -> modify (addHistory line)+        _ -> return ()+ repeatTillFinish :: forall m s d      . (MonadTrans d, Term (d m), LineState s, MonadReader Prefs m)             => TermOps -> d m Event -> String -> s -> KeyMap m s @@ -147,15 +180,10 @@         loop s processor = do                 event <- handle (\(e::SomeException) -> movePast prefix s >> throwIO e) getEvent                 case event of-                    WindowResize -> do-                        oldLayout <- ask-                        newLayout <- liftIO $ getLayout tops-                        if oldLayout == newLayout-                            then loop s processor-                            else local newLayout $ do-                                reposition oldLayout (lineChars prefix s)-                                loop s processor-                    KeyInput k -> case lookupKM processor k of+                    WindowResize -> withReposition tops prefix s $ loop s processor+                    KeyInput k -> do+                      action <- lift $ lookupKey processor k+                      case action of                         Nothing -> actBell >> loop s processor                         Just g -> case g s of                             Left r -> movePast prefix s >> return r@@ -164,16 +192,6 @@                                         drawEffect prefix s effect                                         loop (effectState effect) next -{-- -When stdin is not a console, just read in one line of input.--NOTE: this behavior "breaks" when we run for example "cat | Test":-Printing the input to stdout is redundant because cat already echoes what the user has-typed.-Given the tradeoffs of all of the different ways of piping to/from stdin/stdout,-I think it's fine because this case seems least likely to occur in practice.--}- simpleFileLoop :: MonadIO m => String -> RunTerm -> m (Maybe String) simpleFileLoop prefix rterm = liftIO $ do     putStrOut rterm prefix@@ -219,6 +237,64 @@ movePast :: (LineState s, Term m) => String -> s -> m () movePast prefix s = moveToNextLine (lineChars prefix s) +withReposition :: (LineState s, Term m) => TermOps -> String -> s -> m a -> m a+withReposition tops prefix s f = do+    oldLayout <- ask+    newLayout <- liftIO $ getLayout tops+    if oldLayout == newLayout+        then f+        else local newLayout $ do+                reposition oldLayout (lineChars prefix s)+                f+----------++{- | Reads one character of input, without waiting for a newline.+-}+getInputChar :: MonadException m => String -- ^ The input prompt+                    -> InputT m (Maybe Char)+getInputChar prefix = do+    liftIO $ hFlush stdout+    rterm <- ask+    echo <- liftIO $ hGetEcho stdin+    case termOps rterm of+        Just tops | echo -> getInputCmdChar tops prefix+        _ -> simpleFileChar prefix rterm++simpleFileChar :: MonadIO m => String -> RunTerm -> m (Maybe Char)+simpleFileChar prefix rterm = liftIO $ do+    putStrOut rterm prefix+    atEOF <- hIsEOF stdin+    if atEOF+        then return Nothing+        else liftM Just getChar -- TODO: utf8?++-- TODO: it might be possible to unify this function with getInputCmdLine,+-- maybe by calling repeatTillFinish here...+-- It shouldn't be too hard to make Commands parametrized over a return+-- value (which would be Maybe Char in this case).+-- My primary obstacle is that there's currently no way to have a+-- single character input cause a character to be printed and then+-- immediately exit without waiting for Return to be pressed.+getInputCmdChar :: MonadException m => TermOps -> String -> InputT m (Maybe Char)+getInputCmdChar tops prefix = runInputCmdT tops $ runTerm tops $ \getEvent -> do+                                                drawLine prefix emptyIM+                                                loop getEvent+    where+        s = emptyIM+        loop :: Term m => m Event -> m (Maybe Char)+        loop getEvent = do+            event <- handle (\(e::SomeException) -> movePast prefix emptyIM >> throwIO e) getEvent+            case event of+                KeyInput (Key m (KeyChar c))+                    | m /= noModifier -> loop getEvent+                    | c == '\EOT'     -> movePast prefix s >> return Nothing+                    | isPrint c -> do+                            let s' = insertChar c s+                            drawLineStateDiff prefix s s'+                            movePast prefix s'+                            return (Just c)+                WindowResize -> withReposition tops prefix emptyIM $ loop getEvent+                _ -> loop getEvent   ------------

@@ -4,7 +4,6 @@ import System.Console.Haskeline.Term import System.Console.Haskeline.LineState import System.Console.Haskeline.Monads as Monads-import System.Console.Haskeline.Command  import System.IO 

@@ -24,8 +24,9 @@ import System.Environment  import System.Console.Haskeline.Monads-import System.Console.Haskeline.Command+import System.Console.Haskeline.Key import System.Console.Haskeline.Term+import System.Console.Haskeline.Prefs  import GHC.IOBase (haFD,FD) import GHC.Handle (withHandle_)@@ -61,8 +62,7 @@     return $ Just $ Layout {height=read r,width=read c}  tinfoLayout :: Maybe Terminal -> IO (Maybe Layout)-tinfoLayout Nothing = return Nothing-tinfoLayout (Just t) = return $ getCapability t $ do+tinfoLayout = maybe (return Nothing) $ \t -> return $ getCapability t $ do                         r <- termColumns                         c <- termLines                         return Layout {height=r,width=c}@@ -79,20 +79,31 @@ -------------------- -- Key sequences -getKeySequences :: Maybe Terminal -> IO (TreeMap Char Key)+getKeySequences :: (MonadIO m, MonadReader Prefs m)+        => Maybe Terminal -> m (TreeMap Char Key) getKeySequences term = do-    sttys <- sttyKeys+    sttys <- liftIO sttyKeys+    customKeySeqs <- getCustomKeySeqs     let tinfos = maybe [] terminfoKeys term     -- note ++ acts as a union; so the below favors sttys over tinfos-    return $ listToTree $ ansiKeys ++ tinfos ++ sttys+    return $ listToTree+        $ ansiKeys ++ tinfos ++ sttys ++ customKeySeqs+  where+    getCustomKeySeqs = do+        kseqs <- asks customKeySequences+        termName <- liftIO $ handle (\(_::IOException) -> return "") (getEnv "TERM")+        let isThisTerm = maybe True (==termName)+        return $ map (\(_,cs,k) ->(cs,k))+            $ filter (\(kseqs',_,_) -> isThisTerm kseqs')+            $ kseqs   ansiKeys :: [(String, Key)]-ansiKeys = [("\ESC[D",  KeyLeft)-            ,("\ESC[C",  KeyRight)-            ,("\ESC[A",  KeyUp)-            ,("\ESC[B",  KeyDown)-            ,("\b",      Backspace)]+ansiKeys = [("\ESC[D",  simpleKey LeftKey)+            ,("\ESC[C",  simpleKey RightKey)+            ,("\ESC[A",  simpleKey UpKey)+            ,("\ESC[B",  simpleKey DownKey)+            ,("\b",      simpleKey Backspace)]  terminfoKeys :: Terminal -> [(String,Key)] terminfoKeys term = catMaybes $ map getSequence keyCapabilities@@ -101,18 +112,21 @@                             keys <- getCapability term cap                             return (keys,x)         keyCapabilities = -                [(keyLeft,KeyLeft),-                (keyRight,KeyRight),-                (keyUp,KeyUp),-                (keyDown,KeyDown),-                (keyBackspace,Backspace),-                (keyDeleteChar,DeleteForward)]+                [(keyLeft,      simpleKey LeftKey)+                ,(keyRight,      simpleKey RightKey)+                ,(keyUp,         simpleKey UpKey)+                ,(keyDown,       simpleKey DownKey)+                ,(keyBackspace,  simpleKey Backspace)+                ,(keyDeleteChar, simpleKey Delete)+                ,(keyHome,       simpleKey Home)+                ,(keyEnd,        simpleKey End)+                ]  sttyKeys :: IO [(String, Key)] sttyKeys = do     attrs <- getTerminalAttributes stdInput     let getStty (k,c) = do {str <- controlChar attrs k; return ([str],c)}-    return $ catMaybes $ map getStty [(Erase,Backspace),(Kill,KillLine)]+    return $ catMaybes $ map getStty [(Erase,simpleKey Backspace),(Kill,simpleKey KillLine)]                          newtype TreeMap a b = TreeMap (Map.Map a (Maybe b, TreeMap a b))                         deriving Show@@ -147,9 +161,10 @@     | Just (k,ds) <- lookupChars baseMap cs             = k : lexKeys baseMap ds lexKeys baseMap ('\ESC':cs)-    | (k:ks) <- lexKeys baseMap cs-            = KeyMeta k : ks-lexKeys baseMap (c:cs) = KeyChar c : lexKeys baseMap cs+-- TODO: what's the right thing ' to do here?+    | k:ks <- lexKeys baseMap cs+            = metaKey k : ks+lexKeys baseMap (c:cs) = simpleChar c : lexKeys baseMap cs  lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key,[Char]) lookupChars _ [] = Nothing@@ -163,20 +178,20 @@  ----------------------------- -withPosixGetEvent :: MonadException m => Handle -> Maybe Terminal -> (m Event -> m a) -> m a+withPosixGetEvent :: (MonadTrans t, MonadIO m, MonadException (t m), MonadReader Prefs m) +                        => Handle -> Maybe Terminal -> (t m Event -> t m a) -> t m a withPosixGetEvent h term f = do-    baseMap <- liftIO (getKeySequences term)+    baseMap <- lift $ getKeySequences term     eventChan <- liftIO $ newTChanIO     wrapKeypad h term $ withWindowHandler eventChan         $ f $ liftIO $ getEvent baseMap eventChan  -- If the keypad on/off capabilities are defined, wrap the computation with them. wrapKeypad :: MonadException m => Handle -> Maybe Terminal -> m a -> m a-wrapKeypad _ Nothing f = f-wrapKeypad h (Just term) f = (maybeOutput keypadOn >> f) -                            `finally` maybeOutput keypadOff+wrapKeypad h = maybe id $ \term f -> (maybeOutput term keypadOn >> f) +                            `finally` maybeOutput term keypadOff   where-    maybeOutput cap = liftIO $ hRunTermOutput h term $+    maybeOutput term cap = liftIO $ hRunTermOutput h term $                             fromMaybe mempty (getCapability term cap)  withWindowHandler :: MonadException m => TChan Event -> m a -> m a@@ -199,17 +214,15 @@ getEvent baseMap = keyEventLoop readKeyEvents   where     bufferSize = 100-    readKeyEvents eventChan = do+    readKeyEvents = do         -- Read at least one character of input, and more if available.         -- In particular, the characters making up a control sequence will all         -- be available at once, so we can process them together with lexKeys.-        threadWaitRead stdInput+        threadWaitRead stdInput -- hWaitForInput doesn't work with -threaded on+                                -- ghc < 6.10 (#2363 in ghc's trac)         bs <- B.hGetNonBlocking stdin bufferSize         let cs = UTF8.toString bs-        let ks = map KeyInput $ lexKeys baseMap cs-        if null ks-            then readKeyEvents eventChan-            else atomically $ mapM_ (writeTChan eventChan) ks+        return $ map KeyInput $ lexKeys baseMap cs  -- fails if stdin is not a handle or if we couldn't access /dev/tty. openTTY :: IO (Maybe Handle)

@@ -12,7 +12,6 @@  import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.LineState-import System.Console.Haskeline.Command import System.Console.Haskeline.Term import System.Console.Haskeline.Backend.Posix import qualified Codec.Binary.UTF8.String as UTF8@@ -110,7 +109,7 @@     case mterm of         -- XXX narrow this: either an ioexception (from getenv) or a          -- usererror.-        Left (_::SomeException) -> return Nothing+        Left (_::SetupTermError) -> return Nothing         Right term -> case getCapability term getActions of             Nothing -> return Nothing             Just actions -> fmap Just $ posixRunTerm $ \h -> 

@@ -18,8 +18,11 @@ import Control.Concurrent hiding (throwTo)
 import Control.Concurrent.STM
 import Data.Bits
+import Data.Char(isUpper)
+import Data.Maybe(mapMaybe)
+import Control.Monad
 
-import System.Console.Haskeline.Command
+import System.Console.Haskeline.Key
 import System.Console.Haskeline.Monads
 import System.Console.Haskeline.LineState
 import System.Console.Haskeline.Term
@@ -32,24 +35,29 @@ foreign import stdcall "windows.h WaitForSingleObject" c_WaitForSingleObject
     :: HANDLE -> DWORD -> IO DWORD
 
+foreign import stdcall "windows.h GetNumberOfConsoleInputEvents"
+    c_GetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO Bool
+
+getNumberOfEvents :: HANDLE -> IO Int
+getNumberOfEvents h = alloca $ \numEventsPtr -> do
+    failIfFalse_ "GetNumberOfConsoleInputEvents"
+        $ c_GetNumberOfConsoleInputEvents h numEventsPtr
+    fmap fromEnum $ peek numEventsPtr
+
 getEvent :: HANDLE -> IO Event
-getEvent h = newTChanIO >>= keyEventLoop eventIntoChan
-  where
-    eventIntoChan tchan = eventLoop h >>= atomically . writeTChan tchan
+getEvent h = newTChanIO >>= keyEventLoop (eventReader h)
 
-eventLoop :: HANDLE -> IO Event
-eventLoop h = do
+eventReader :: HANDLE -> IO [Event]
+eventReader h = do
     let waitTime = 500 -- milliseconds
     ret <- c_WaitForSingleObject h waitTime
     yield -- otherwise, the above foreign call causes the loop to never 
           -- respond to the killThread
     if ret /= (#const WAIT_OBJECT_0)
-        then eventLoop h
+        then eventReader h
         else do
-            e <- readEvent h
-            case eventToKey e of
-	        Just k -> return (KeyInput k)
-    	        Nothing -> eventLoop h
+            es <- readEvents h
+            return $ mapMaybe processEvent es
                        
 getConOut :: IO (Maybe HANDLE)
 getConOut = handle (\(_::IOException) -> return Nothing) $ fmap Just
@@ -57,27 +65,38 @@                         (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing
                     oPEN_EXISTING 0 Nothing
 
-
-eventToKey :: InputEvent -> Maybe Key
-eventToKey KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc,
+processEvent :: InputEvent -> Maybe Event
+processEvent KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc,
                     controlKeyState = cstate}
-        = if isMeta then fmap KeyMeta maybeKey else maybeKey
+    = fmap (KeyInput . Key modifier) $ keyFromCode vc `mplus` simpleKeyChar
   where
-    maybeKey = if c /= '\NUL' 
-                    then Just (KeyChar c)
-                    else keyFromCode vc
-    isMeta = 0 /= (cstate .&. (#const RIGHT_ALT_PRESSED
-                                    .|. #const LEFT_ALT_PRESSED) )
-eventToKey _ = Nothing
+    simpleKeyChar = guard (c /= '\NUL') >> return (KeyChar c)
+    testMod ck = (cstate .&. ck) /= 0
+    modifier = Modifier {hasMeta = testMod ((#const RIGHT_ALT_PRESSED) 
+                                        .|. (#const LEFT_ALT_PRESSED))
+                        ,hasControl = testMod ((#const RIGHT_CTRL_PRESSED) 
+                                        .|. (#const LEFT_CTRL_PRESSED))
+                                    && not (c > '\NUL' && c <= '\031')
+                        ,hasShift = testMod (#const SHIFT_PRESSED)
+                                    && not (isUpper c)
+                        }
 
-keyFromCode :: WORD -> Maybe Key
+processEvent WindowEvent = Just WindowResize
+processEvent _ = Nothing
+
+keyFromCode :: WORD -> Maybe BaseKey
 keyFromCode (#const VK_BACK) = Just Backspace
-keyFromCode (#const VK_LEFT) = Just KeyLeft
-keyFromCode (#const VK_RIGHT) = Just KeyRight
-keyFromCode (#const VK_UP) = Just KeyUp
-keyFromCode (#const VK_DOWN) = Just KeyDown
-keyFromCode (#const VK_DELETE) = Just DeleteForward
--- TODO: KillLine
+keyFromCode (#const VK_LEFT) = Just LeftKey
+keyFromCode (#const VK_RIGHT) = Just RightKey
+keyFromCode (#const VK_UP) = Just UpKey
+keyFromCode (#const VK_DOWN) = Just DownKey
+keyFromCode (#const VK_DELETE) = Just Delete
+keyFromCode (#const VK_HOME) = Just Home
+keyFromCode (#const VK_END) = Just End
+-- The Windows console will return '\r' when return is pressed.
+keyFromCode (#const VK_RETURN) = Just (KeyChar '\n')
+-- TODO: KillLine?
+-- TODO: function keys.
 keyFromCode _ = Nothing
     
 data InputEvent = KeyEvent {keyDown :: BOOL,
@@ -88,21 +107,30 @@                           controlKeyState :: DWORD}
             -- TODO: WINDOW_BUFFER_SIZE_RECORD
             -- I cant figure out how the user generates them.
+           | WindowEvent
            | OtherEvent
                         deriving Show
 
-readEvent :: HANDLE -> IO InputEvent
-readEvent h = allocaBytes (#size INPUT_RECORD) $ \pRecord -> 
-                        alloca $ \numEventsPtr -> do
-    failIfFalse_ "ReadConsoleInput" 
-        $ c_ReadConsoleInput h pRecord 1 numEventsPtr
-    -- useful? numEvents <- peek numEventsPtr
+peekEvent :: Ptr () -> IO InputEvent
+peekEvent pRecord = do
     eventType :: WORD <- (#peek INPUT_RECORD, EventType) pRecord
     let eventPtr = (#ptr INPUT_RECORD, Event) pRecord
     case eventType of
         (#const KEY_EVENT) -> getKeyEvent eventPtr
+        (#const WINDOW_BUFFER_SIZE_EVENT) -> return WindowEvent
         _ -> return OtherEvent
-        
+
+readEvents :: HANDLE -> IO [InputEvent]
+readEvents h = do
+    n <- getNumberOfEvents h
+    alloca $ \numEventsPtr -> 
+        allocaBytes (n * #size INPUT_RECORD) $ \pRecord -> do
+            failIfFalse_ "ReadConsoleInput" 
+                $ c_ReadConsoleInput h pRecord (toEnum n) numEventsPtr
+            numRead <- fmap fromEnum $ peek numEventsPtr
+            forM [0..toEnum numRead-1] $ \i -> peekEvent
+                $ pRecord `plusPtr` (i * #size INPUT_RECORD)
+
 getKeyEvent :: Ptr () -> IO InputEvent
 getKeyEvent p = do
     kDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) p
@@ -177,6 +205,26 @@ messageBeep :: IO ()
 messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures.
 
+
+----------
+-- Console mode
+foreign import stdcall "windows.h GetConsoleMode" c_GetConsoleMode
+    :: HANDLE -> Ptr DWORD -> IO Bool
+
+foreign import stdcall "windows.h SetConsoleMode" c_SetConsoleMode
+    :: HANDLE -> DWORD -> IO Bool
+
+withWindowMode :: MonadException m => m a -> m a
+withWindowMode f = do
+    h <- liftIO $ getStdHandle sTD_INPUT_HANDLE
+    bracket (getConsoleMode h) (setConsoleMode h)
+            $ \m -> setConsoleMode h (m .|. (#const ENABLE_WINDOW_INPUT)) >> f
+  where
+    getConsoleMode h = liftIO $ alloca $ \p -> do
+            failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h p
+            peek p
+    setConsoleMode h m = liftIO $ failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h m
+
 ----------------------------
 -- Drawing
 
@@ -233,7 +281,10 @@ 
 instance (MonadException m, MonadLayout m) => Term (Draw m) where
     drawLineDiff = drawLineDiffWin
-    reposition _ _ = return () -- TODO when we capture resize events.
+    -- TODO now that we capture resize events.
+    -- first, looks like the cursor stays on the same line but jumps
+    -- to the beginning if cut off.
+    reposition _ _ = return ()
 
     printLines [] = return ()
     printLines ls = printText $ intercalate crlf ls ++ crlf
@@ -263,7 +314,7 @@                 Nothing -> fileRunTerm
                 Just h -> return RunTerm {
                             putStrOut = putter,
-                            wrapInterrupt = withCtrlCHandler,
+                            wrapInterrupt = withWindowMode . withCtrlCHandler,
                             termOps = Just TermOps {
                                             getLayout = getBufferSize h,
                                             runTerm = consoleRunTerm h},

@@ -1,12 +1,8 @@ module System.Console.Haskeline.Command(-                        Key(..),-                        controlKey,-                        metaChar,-                        Layout(..),                         -- * Commands                         Effect(..),                         KeyMap(), -                        lookupKM,+                        lookupKey,                         KeyAction(..),                         CmdAction(..),                         (>=>),@@ -35,25 +31,13 @@  import Data.Char(isPrint) import Control.Monad(mplus)-import Data.Bits import System.Console.Haskeline.LineState+import System.Console.Haskeline.Key+import System.Console.Haskeline.Monads+import System.Console.Haskeline.Prefs+import qualified Data.Map as Map -data Layout = Layout {width, height :: Int}-                    deriving (Show,Eq) -data Key = KeyChar Char | KeyMeta Key-            | KeyLeft | KeyRight | KeyUp | KeyDown-            | Backspace | DeleteForward | KillLine-                deriving (Eq,Ord,Show)---- Easy translation of control characters; e.g., Ctrl-G or Ctrl-g or ^G-controlKey :: Char -> Key-controlKey '?' = KeyChar (toEnum 127)-controlKey c = KeyChar $ toEnum $ fromEnum c .&. complement (bit 5 .|. bit 6)--metaChar :: Char -> Key-metaChar = KeyMeta . KeyChar- data Effect s = Change {effectState :: s}                | PrintLines {linesToPrint :: [String], effectState :: s}               | Redraw {shouldClearScreen :: Bool, effectState :: s}@@ -62,6 +46,11 @@ newtype KeyMap m s = KeyMap {lookupKM :: Key -> Maybe              (s -> Either (Maybe String) (m (KeyAction m)))} +lookupKey :: MonadReader Prefs m => KeyMap n s -> Key+        -> m (Maybe (s -> Either (Maybe String) (n (KeyAction n))))+lookupKey processor k = asks $ lookupKM processor +                        . Map.findWithDefault k k . customBindings+ useKey :: Key -> (s -> Either (Maybe String) (m (KeyAction m))) -> KeyMap m s useKey k f = KeyMap $ \k' -> if k==k' then Just f else Nothing @@ -136,7 +125,7 @@ charCommand :: (LineState t, Monad m) => (Char -> s -> m (Effect t))                     -> Command m s t charCommand f = Command $ \next -> KeyMap $ \k -> case k of-                    KeyChar c | isPrint c -> Just $ \s -> Right $ do+                    Key m (KeyChar c) | isPrint c && m==noModifier-> Just $ \s -> Right $ do                                     effect <- f c s                                     return (KeyAction effect next)                     _ -> Nothing

@@ -6,6 +6,8 @@                             ) where  import System.Console.Haskeline.Command+import System.Console.Haskeline.Key+import System.Console.Haskeline.Term(Layout(..)) import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT import System.Console.Haskeline.Prefs@@ -21,7 +23,7 @@ makeCompletion :: Monad m => InsertMode -> InputCmdT m (InsertMode, [Completion]) makeCompletion (IMode xs ys) = do     f <- asks complete-    (rest,completions) <- liftCmdT (f xs)+    (rest,completions) <- liftCmdT (f (xs, ys))     return (IMode rest ys,completions)  -- | Create a 'Command' for word completion.@@ -70,8 +72,8 @@         Change (Message im ("Display all " ++ show numCompletions                             ++ " possibilities? (y or n)"))                     >=> choiceCmd [-                            KeyChar 'y' +> acceptKey (const printingCmd)-                            , KeyChar 'n' +> change messageState+                            simpleChar 'y' +> acceptKey (const printingCmd)+                            , simpleChar 'n' +> change messageState                             ]     _ -> printingCmd @@ -93,9 +95,10 @@ -- TODO: move testing of nullity into here pagingCommands :: Monad m => [String] -> Command (InputCmdT m) (Message InsertMode) InsertMode pagingCommands ws = choiceCmd [-                            KeyChar ' ' +> acceptKeyM (printPage ws)-                            ,KeyChar 'q' +> change messageState-                            ,KeyChar '\n' +> acceptKey (printOneLine ws)+                            simpleChar ' ' +> acceptKeyM (printPage ws)+                            ,simpleChar 'q' +> change messageState+                            ,simpleChar '\n' +> acceptKey (printOneLine ws)+                            ,simpleKey DownKey +> acceptKey (printOneLine ws)                             ]  

@@ -2,17 +2,12 @@  import System.Console.Haskeline.LineState import System.Console.Haskeline.Command+import System.Console.Haskeline.Key import Control.Monad(liftM,mplus) import System.Console.Haskeline.Monads import Data.List import Data.Maybe(fromMaybe)-import Control.Exception.Extensible(evaluate)-import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as UTF8--import System.Directory(doesFileExist)--data History = History {historyLines :: [String]} -- stored in reverse+import System.Console.Haskeline.History  data HistLog = HistLog {pastHistory, futureHistory :: [String]}                     deriving Show@@ -31,28 +26,13 @@ histLog hist = HistLog {pastHistory = historyLines hist, futureHistory = []}  runHistoryFromFile :: MonadIO m => Maybe FilePath -> Maybe Int -> StateT History m a -> m a-runHistoryFromFile Nothing _ f = evalStateT' (History []) f+runHistoryFromFile Nothing _ f = evalStateT' emptyHistory f runHistoryFromFile (Just file) stifleAmt f = do-    contents <- liftIO $ do-                exists <- doesFileExist file-                if exists-                    -- use binary file I/O to avoid Windows CRLF line endings-                    -- which cause confusion when switching between systems.-                    then fmap UTF8.toString (B.readFile file)-                    else return ""-    liftIO $ evaluate (length contents) -- force file closed-    let oldHistory = History (lines contents)-    (x,newHistory) <- runStateT f oldHistory-    let stifle = case stifleAmt of-                    Nothing -> id-                    Just m -> take m-    liftIO $ B.writeFile file $ UTF8.fromString -        $ unlines $ stifle $ historyLines newHistory+    oldHistory <- liftIO $ readHistory file+    (x,newHistory) <- runStateT f (stifleHistory stifleAmt oldHistory)+    liftIO $ writeHistory file newHistory     return x -addHistory :: MonadState History m => String -> m ()-addHistory l = modify $ \(History ls) -> History (l:ls)- runHistLog :: Monad m => StateT HistLog m a -> StateT History m a runHistLog f = do     history <- get@@ -154,15 +134,14 @@                  , forwardKey +> change (startSearchMode Forward)                  ] >|> keepSearching     where-        backKey = controlKey 'r'-        forwardKey = controlKey 's'+        backKey = ctrlChar 'r'+        forwardKey = ctrlChar 's'         keepSearching = choiceCmd [                             choiceCmd [                                 charCommand oneMoreChar                                 , backKey +> simpleCommand (searchMore Reverse)                                 , forwardKey +> simpleCommand (searchMore Forward)-                                , Backspace +> change delLastChar-                                , KeyChar '\b' +> change delLastChar+                                , simpleKey Backspace +> change delLastChar                                 ] >|> keepSearching                             , changeWithoutKey foundHistory -- abort                             ]

@@ -1,6 +1,7 @@ module System.Console.Haskeline.Command.Undo where  import System.Console.Haskeline.Command+import System.Console.Haskeline.Key import System.Console.Haskeline.LineState import System.Console.Haskeline.Monads 

@@ -20,11 +20,14 @@  import System.Console.Haskeline.Monads --- | Performs completions from a reversed 'String'.  --- The output 'String' is also reversed.--- Use 'completeWord' to build these functions.--type CompletionFunc m = String -> m (String, [Completion])+-- | Performs completions from the given line state.+--+-- The first 'String' argument is the contents of the line to the left of the cursor,+-- reversed.+-- The second 'String' argument is the contents of the line to the right of the cursor.+--+-- The output 'String' is the unused portion of the left half of the line, reversed.+type CompletionFunc m = (String,String) -> m (String, [Completion])   data Completion = Completion {replacement  :: String, -- ^ Text to insert in line.@@ -39,7 +42,7 @@  -- | Disable completion altogether. noCompletion :: Monad m => CompletionFunc m-noCompletion s = return (s,[])+noCompletion (s,_) = return (s,[])  -------------- -- Word break functions@@ -50,7 +53,7 @@         -> String -- ^ List of characters which count as whitespace         -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions         -> CompletionFunc m-completeWord esc ws f line = do+completeWord esc ws f (line, _) = do     let (word,rest) = case esc of                         Nothing -> break (`elem` ws) line                         Just e -> escapedBreak e line@@ -102,7 +105,8 @@                             -> CompletionFunc m -- ^ Alternate completion to perform if the                                              -- cursor is not at a quoted word                             -> CompletionFunc m-completeQuotedWord esc qs completer alterative = \line -> case splitAtQuote esc qs line of+completeQuotedWord esc qs completer alterative line@(left,_)+  = case splitAtQuote esc qs left of     Just (w,rest) | isUnquoted esc qs rest -> do         cs <- completer (reverse w)         return (rest, map (addQuotes . escapeReplacement esc qs) cs)

@@ -1,6 +1,7 @@ module System.Console.Haskeline.Emacs where  import System.Console.Haskeline.Command+import System.Console.Haskeline.Key import System.Console.Haskeline.Command.Completion import System.Console.Haskeline.Command.History import System.Console.Haskeline.Command.Undo@@ -16,40 +17,39 @@  simpleActions, controlActions :: InputCmd InsertMode InsertMode simpleActions = choiceCmd -            [ KeyChar '\n' +> finish-	    , KeyChar '\r' +> finish-            , KeyLeft +> change goLeft-            , KeyRight +> change goRight-            , Backspace +> change deletePrev-            , KeyChar '\b' +> change deletePrev-	    , DeleteForward +> change deleteNext +            [ simpleChar '\n' +> finish+            , simpleKey LeftKey +> change goLeft+            , simpleKey RightKey +> change goRight+            , simpleKey Backspace +> change deletePrev+            , simpleKey Delete +> change deleteNext              , changeFromChar insertChar-            , saveForUndo $ KeyChar '\t' +> completionCmd-            , KeyUp +> historyBack-            , KeyDown +> historyForward+            , saveForUndo $ simpleChar '\t' +> completionCmd+            , simpleKey UpKey +> historyBack+            , simpleKey DownKey +> historyForward             , searchHistory             ]               controlActions = choiceCmd-            [ controlKey 'a' +> change moveToStart -            , controlKey 'e' +> change moveToEnd-            , controlKey 'b' +> change goLeft-            , controlKey 'f' +> change goRight-            , controlKey 'd' +> deleteCharOrEOF-            , controlKey 'l' +> clearScreenCmd+            [ ctrlChar 'a' +> change moveToStart +            , ctrlChar 'e' +> change moveToEnd+            , ctrlChar 'b' +> change goLeft+            , ctrlChar 'f' +> change goRight+            , ctrlChar 'd' +> deleteCharOrEOF+            , ctrlChar 'l' +> clearScreenCmd             , metaChar 'f' +> change wordRight             , metaChar 'b' +> change wordLeft-            , controlKey '_' +> commandUndo-            , controlKey 'x' +> change id -                >|> choiceCmd [controlKey 'u' +> commandUndo+            , ctrlChar '_' +> commandUndo+            , ctrlChar 'x' +> change id +            , simpleKey Home +> change moveToStart+            , simpleKey End +> change moveToEnd+                >|> choiceCmd [ctrlChar 'u' +> commandUndo                               , continue]             , saveForUndo $ choiceCmd-                [ controlKey 'w' +> change (deleteFromMove bigWordLeft)-                , KeyMeta Backspace +> change (deleteFromMove wordLeft)-                , KeyMeta (KeyChar '\b') +> change (deleteFromMove wordLeft)+                [ ctrlChar 'w' +> change (deleteFromMove bigWordLeft)+                , metaKey (simpleKey Backspace) +> change (deleteFromMove wordLeft)                 , metaChar 'd' +> change (deleteFromMove wordRight)-                , controlKey 'k' +> change (deleteFromMove moveToEnd)-                , KillLine +> change (deleteFromMove moveToStart)+                , ctrlChar 'k' +> change (deleteFromMove moveToEnd)+                , simpleKey KillLine +> change (deleteFromMove moveToStart)                 ]             ] 

@@ -0,0 +1,90 @@+{- |+This module provides a low-level API to the line history stored in the @InputT@ monad transformer.+++For most application, it should suffice to instead use the following @Settings@ flags:++  * @autoAddHistory@: add nonblank lines to the command history ('True' by default).++  * @historyFile@: read/write the history to a file before and after the line input session.++If you do want custom history behavior, you may need to disable the above default setting(s).++-}+module System.Console.Haskeline.History(+                        History(),+                        emptyHistory,+                        addHistory,+                        historyLines,+                        readHistory,+                        writeHistory,+                        stifleHistory,+                        stifleAmount,+                        ) where++import qualified Data.Sequence as Seq+import Data.Foldable++import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as UTF8+import Control.Exception.Extensible++import System.Directory(doesFileExist)++data History = History {histLines :: Seq.Seq String,+                        stifleAmt :: Maybe Int}+                    -- stored in reverse++-- | The maximum number of lines stored in the history.  If 'Nothing', the history storage is unlimited.+stifleAmount :: History -> Maybe Int+stifleAmount = stifleAmt++instance Show History where+    show = show . histLines++emptyHistory :: History+emptyHistory = History Seq.empty Nothing++-- | The input lines stored in the history (newest first)+historyLines :: History -> [String]+historyLines = toList . histLines++-- | Reads the line input history from the given file.  Returns+-- 'emptyHistory' if the file does not exist or could not be read.+readHistory :: FilePath -> IO History+readHistory file = handle (\(_::IOException) -> return emptyHistory) $ do+    exists <- doesFileExist file+    contents <- if exists+        -- use binary file I/O to avoid Windows CRLF line endings+        -- which cause confusion when switching between systems.+        then fmap UTF8.toString (B.readFile file)+        else return ""+    evaluate (length contents) -- force file closed+    return $ History {histLines = Seq.fromList $ lines contents,+                    stifleAmt = Nothing}++-- | Writes the line history to the given file.  If there is an+-- error when writing the file, it will be ignored.+writeHistory :: FilePath -> History -> IO ()+writeHistory file = handle (\(_::IOException) -> return ())+        . B.writeFile file . UTF8.fromString+        . unlines . historyLines ++-- | Limit the number of lines stored in the history.+stifleHistory :: Maybe Int -> History -> History+stifleHistory Nothing hist = hist {stifleAmt = Nothing}+stifleHistory a@(Just n) hist = History {histLines = stifleFnc (histLines hist),+                                stifleAmt = a}+    where+        stifleFnc = if n > Seq.length (histLines hist)+                        then id+                        else Seq.fromList . take n . toList++addHistory :: String -> History -> History+addHistory s h = h {histLines = s Seq.<| stifledLines}+  where+    stifledLines = if maybe True (> Seq.length (histLines h)) (stifleAmt h)+                    then histLines h+                    else case Seq.viewr (histLines h) of+                            Seq.EmptyR -> histLines h -- shouldn't ever happen+                            ls Seq.:> _ -> ls

@@ -0,0 +1,102 @@+{- |+This module provides a stateful, IO-based interface to Haskeline, which may be easier to+integrate into some existing programs or libraries.++It is strongly recommended to use the safer, monadic API of+"System.Console.Haskeline", if possible, rather than the explicit state management+functions of this module.++The equivalent REPL example is:++@+import System.Console.Haskeline+import System.Console.Haskeline.IO+import Control.Concurrent++main = bracketOnError (initializeInput defaultSettings)+            cancelInput -- This will only be called if an exception such+                            -- as a SigINT is received.+            (\\hd -> loop hd >> closeInput hd)+    where+        loop :: InputState -> IO ()+        loop hd = do+            minput <- queryInput hd (getInputLine \"% \")+            case minput of+                Nothing -> return ()+                Just \"quit\" -> return ()+                Just input -> do queryInput hd $ outputStrLn+                                    $ \"Input was: \" ++ input+                                 loop hd+@+++-}+module System.Console.Haskeline.IO(+                        InputState(),+                        initializeInput,+                        closeInput,+                        cancelInput,+                        queryInput+                        ) where++import System.Console.Haskeline hiding (completeFilename)+import Control.Concurrent+import Control.Concurrent.MVar+import System.IO++import Control.Monad.Trans++-- Providing a non-monadic API for haskeline+-- A process is forked off which runs the monadic InputT API+-- and actions to be run are passed to it through the following MVars.++data Request = forall a . Request (InputT IO a) (MVar a)++data InputState = HD {forkedThread :: ThreadId,+                        requestVar :: MVar (Maybe Request),+                        subthreadFinished :: MVar ()+                    }++-- | Initialize a session of line-oriented user interaction.+initializeInput :: Settings IO -> IO InputState+initializeInput settings = do+    reqV <- newEmptyMVar+    finished <- newEmptyMVar+    tid <- forkIO (runHaskeline settings reqV finished)+    return HD {requestVar = reqV, forkedThread = tid,+                subthreadFinished = finished}++runHaskeline :: Settings IO -> MVar (Maybe Request) -> MVar () -> IO ()+runHaskeline settings reqV finished = runInputT settings loop+                    `finally` putMVar finished ()+    where+        loop = do+            mf <- liftIO $ takeMVar reqV+            case mf of+                Nothing -> return ()+                Just (Request f var) -> f >>= liftIO . putMVar var >> loop++-- | Finish and clean up the line-oriented user interaction session.  Blocks on an+-- existing call to 'queryInput'.+closeInput :: InputState -> IO ()+closeInput hd = putMVar (requestVar hd) Nothing >> takeMVar (subthreadFinished hd)++-- | Cancel and clean up the user interaction session.  Does not block on an existing+-- call to 'queryInput'.+cancelInput :: InputState -> IO ()+cancelInput hd = killThread (forkedThread hd) >> takeMVar (subthreadFinished hd)++-- | Run one action (for example, 'getInputLine') as part of a session of user interaction.+--+-- For example, multiple calls to 'queryInput' using the same 'InputState' will share+-- the same input history.  In constrast, multiple calls to 'runInputT' will use distinct+-- histories unless they share the same history file.+--+-- This function should not be called on a closed or cancelled 'InputState'.+queryInput :: InputState -> InputT IO a -> IO a+queryInput hd f = do+    var <- newEmptyMVar+    putMVar (requestVar hd) (Just (Request f var))+    takeMVar var++

@@ -1,11 +1,11 @@ module System.Console.Haskeline.InputT where  +import System.Console.Haskeline.History import System.Console.Haskeline.Command.History import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.Monads as Monads import System.Console.Haskeline.Prefs-import System.Console.Haskeline.Command(Layout) import System.Console.Haskeline.Completion import System.Console.Haskeline.Backend import System.Console.Haskeline.Term@@ -13,11 +13,16 @@ import System.Directory(getHomeDirectory) import System.FilePath import Control.Applicative-import Control.Monad(liftM, ap)+import qualified Control.Monad.State as State  -- | Application-specific customizations to the user interface.-data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion-                            historyFile :: Maybe FilePath+data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion.+                            historyFile :: Maybe FilePath, -- ^ Where to read/write the history at the+                                                        -- start and end of each+                                                        -- line input session.+                            autoAddHistory :: Bool -- ^ If 'True', each nonblank line returned by+                                -- @getInputLine@ will be automatically added to the history.+                             }  -- | Because 'complete' is the only field of 'Settings' depending on @m@,@@ -39,11 +44,11 @@                                         MonadReader RunTerm)  instance Monad m => Functor (InputT m) where-    fmap = liftM+    fmap = State.liftM  instance Monad m => Applicative (InputT m) where     pure = return-    (<*>) = ap+    (<*>) = State.ap  instance MonadTrans InputT where     lift = InputT . lift . lift . lift . lift@@ -52,6 +57,10 @@     block = InputT . block . unInputT     unblock = InputT . unblock . unInputT     catch f h = InputT $ Monads.catch (unInputT f) (unInputT . h)++instance Monad m => State.MonadState History (InputT m) where+    get = get+    put = put  -- for internal use only type InputCmdT m = ReaderT Layout (UndoT (StateT HistLog 

@@ -0,0 +1,119 @@+module System.Console.Haskeline.Key(Key(..),+            Modifier(..),+            BaseKey(..),+            noModifier,+            simpleKey,+            simpleChar,+            metaChar,+            ctrlChar,+            metaKey,+            parseKey+            ) where++import Data.Char+import Control.Monad+import Data.Maybe+import Data.Bits++data Key = Key Modifier BaseKey+            deriving (Show,Eq,Ord)++data Modifier = Modifier {hasControl, hasMeta, hasShift :: Bool}+            deriving (Eq,Ord)++instance Show Modifier where+    show m = show $ catMaybes [maybeUse hasControl "ctrl"+                        , maybeUse hasMeta "meta"+                        , maybeUse hasShift "shift"+                        ]+        where+            maybeUse f str = if f m then Just str else Nothing++noModifier :: Modifier+noModifier = Modifier False False False++data BaseKey = KeyChar Char+             | FunKey Int+             | LeftKey | RightKey | DownKey | UpKey+             -- TODO: is KillLine really a key?+             | KillLine | Home | End+             | Backspace | Delete+            deriving (Show,Eq,Ord)++simpleKey :: BaseKey -> Key+simpleKey = Key noModifier++metaKey :: Key -> Key+metaKey (Key m bc) = Key m {hasMeta = True} bc++simpleChar, metaChar, ctrlChar :: Char -> Key+simpleChar = simpleKey . KeyChar+metaChar = metaKey . simpleChar++ctrlChar = simpleChar . setControlBits++setControlBits :: Char -> Char+setControlBits '?' = toEnum 127+setControlBits c = toEnum $ fromEnum c .&. complement (bit 5 .|. bit 6)++specialKeys :: [(String,BaseKey)]+specialKeys = [("left",LeftKey)+              ,("right",RightKey)+              ,("down",DownKey)+              ,("up",UpKey)+              ,("killline",KillLine)+              ,("home",Home)+              ,("end",End)+              ,("backspace",Backspace)+              ,("delete",Delete)+              ,("return",KeyChar '\n')+              ,("enter",KeyChar '\n')+              ,("tab",KeyChar '\t')+              ,("esc",KeyChar '\ESC')+              ,("escape",KeyChar '\ESC')+              ]++parseModifiers :: [String] -> BaseKey -> Key+parseModifiers strs = Key mods+    where mods = foldl1 (.) (map parseModifier strs) noModifier++parseModifier :: String -> (Modifier -> Modifier)+parseModifier str m = case map toLower str of+    "ctrl" -> m {hasControl = True}+    "control" -> m {hasControl = True}+    "meta" -> m {hasMeta = True}+    "shift" -> m {hasShift = True}+    _ -> m++breakAtDashes :: String -> [String]+breakAtDashes "" = []+breakAtDashes str = case break (=='-') str of+    (xs,'-':rest) -> xs : breakAtDashes rest+    (xs,_) -> [xs]++parseKey :: String -> Maybe Key+parseKey str = fmap canonicalizeKey $ +    case reverse (breakAtDashes str) of+        [ks] -> liftM simpleKey (parseBaseKey ks)+        ks:ms -> liftM (parseModifiers ms) (parseBaseKey ks)+        [] -> Nothing++parseBaseKey :: String -> Maybe BaseKey+parseBaseKey ks = lookup (map toLower ks) specialKeys+                `mplus` parseFunctionKey ks+                `mplus` parseKeyChar ks+    where+        parseKeyChar [c] | isPrint c = Just (KeyChar c)+        parseKeyChar _ = Nothing++        parseFunctionKey (f:ns) | f `elem` "fF" = case reads ns of+            [(n,"")]    -> Just (FunKey n)+            _           -> Nothing+        parseFunctionKey _ = Nothing++canonicalizeKey :: Key -> Key+canonicalizeKey (Key m (KeyChar c))+    | hasControl m = Key m {hasControl = False}+                        (KeyChar (setControlBits c))+    | hasShift m = Key m {hasShift = False} (KeyChar (toUpper c))+canonicalizeKey k = k

@@ -1,17 +1,3 @@-{- |-'Prefs' allow the user to customize the line-editing interface.  They are-read by default from @~/.haskeline@; to override that behavior, use-'readPrefs' and @runInputTWithPrefs@.  --Each line of a @.haskeline@ file defines-one field of the 'Prefs' datatype; field names are case-insensitive and-unparseable lines are ignored.  For example:--> editMode: Vi-> completionType: MenuCompletion-> maxhistorysize: Just 40---} module System.Console.Haskeline.Prefs(                         Prefs(..),                         defaultPrefs,@@ -23,9 +9,24 @@  import Data.Char(isSpace,toLower) import Data.List(foldl')+import qualified Data.Map as Map import System.Console.Haskeline.MonadException(handle,IOException)+import System.Console.Haskeline.Key +{- |+'Prefs' allow the user to customize the line-editing interface.  They are+read by default from @~/.haskeline@; to override that behavior, use+'readPrefs' and @runInputTWithPrefs@. +Each line of a @.haskeline@ file defines+one field of the 'Prefs' datatype; field names are case-insensitive and+unparseable lines are ignored.  For example:++> editMode: Vi+> completionType: MenuCompletion+> maxhistorysize: Just 40++-} data Prefs = Prefs { bellStyle :: !BellStyle,                      editMode :: !EditMode,                      maxHistorySize :: !(Maybe Int),@@ -37,12 +38,15 @@                         -- ^ If more than this number of completion                         -- possibilities are found, then ask before listing                         -- them.-                     listCompletionsImmediately :: !Bool+                     listCompletionsImmediately :: !Bool,                         -- ^ If 'False', completions with multiple possibilities                         -- will ring the bell and only display them if the user                         -- presses @TAB@ again.+                     customBindings :: Map.Map Key Key,+                        -- (termName, keysequence, key)+                     customKeySequences :: [(Maybe String, String,Key)]                      }-                        deriving (Read,Show)+                        deriving Show  data CompletionType = ListCompletion | MenuCompletion             deriving (Read,Show)@@ -54,18 +58,8 @@ data EditMode = Vi | Emacs                     deriving (Show,Read) -{- | The default preferences which may be overwritten in the @.haskeline@ file:--> defaultPrefs = Prefs {bellStyle = AudibleBell,->                      maxHistorySize = Just 100,->                      editMode = Emacs,->                      completionType = ListCompletion,->                      completionPaging = True,->                      completionPromptLimit = Just 100,->                      listCompletionsImmediately = True->                    }---}+-- | The default preferences which may be overwritten in the+-- @.haskeline@ file. defaultPrefs :: Prefs defaultPrefs = Prefs {bellStyle = AudibleBell,                       maxHistorySize = Just 100,@@ -73,14 +67,20 @@                       completionType = ListCompletion,                       completionPaging = True,                       completionPromptLimit = Just 100,-                      listCompletionsImmediately = True+                      listCompletionsImmediately = True,+                      customBindings = Map.empty,+                      customKeySequences = []                     }  mkSettor :: Read a => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs-mkSettor f str = case reads str of-                [(x,_)] -> f x-                _ -> id+mkSettor f str = maybe id f (readMaybe str) +readMaybe :: Read a => String -> Maybe a+readMaybe str = case reads str of+                [(x,_)] -> Just x+                _ -> Nothing++ settors :: [(String, String -> Prefs -> Prefs)] settors = [("bellstyle", mkSettor $ \x p -> p {bellStyle = x})           ,("editmode", mkSettor $ \x p -> p {editMode = x})@@ -89,8 +89,28 @@           ,("completionpaging", mkSettor $ \x p -> p {completionPaging = x})           ,("completionpromptlimit", mkSettor $ \x p -> p {completionPromptLimit = x})           ,("listcompletionsimmediately", mkSettor $ \x p -> p {listCompletionsImmediately = x})-+          ,("bind", addCustomBinding)+          ,("keyseq", addCustomKeySequence)           ]++addCustomBinding :: String -> Prefs -> Prefs+addCustomBinding str p = case map parseKey (words str) of+    [Just k1,Just k2] -> p {customBindings = Map.insert k1 k2 (customBindings p)}+    _ -> p++addCustomKeySequence :: String -> Prefs -> Prefs+addCustomKeySequence str = maybe id addKS $ maybeParse+    where+        maybeParse :: Maybe (Maybe String, String,Key)+        maybeParse = case words str of+            [cstr,kstr] -> parseWords Nothing cstr kstr+            [term,cstr,kstr] -> parseWords (Just term) cstr kstr+            _ -> Nothing+        parseWords mterm cstr kstr = do+            k <- parseKey kstr+            cs <- readMaybe cstr+            return (mterm,cs,k)+        addKS ks p = p {customKeySequences = ks:customKeySequences p}  -- | Read 'Prefs' from a given file.  If there is an error reading the file, -- the 'defaultPrefs' will be returned.

@@ -2,7 +2,8 @@  import System.Console.Haskeline.Monads import System.Console.Haskeline.LineState-import System.Console.Haskeline.Command+import System.Console.Haskeline.Key+import System.Console.Haskeline.Prefs(Prefs)  import Control.Concurrent import Control.Concurrent.STM@@ -28,7 +29,7 @@ data TermOps = TermOps {runTerm :: RunTermType,                         getLayout :: IO Layout} -type RunTermType = forall m a . (MonadLayout m, MonadException m) +type RunTermType = forall m a . (MonadLayout m, MonadException m, MonadReader Prefs m)                      => (forall t . (MonadTrans t, Term (t m), MonadException (t m))                              => (t m Event -> t m a)) -> m a @@ -41,8 +42,8 @@ data Event = WindowResize | KeyInput Key                 deriving Show -keyEventLoop :: (TChan Event -> IO ()) -> TChan Event -> IO Event-keyEventLoop readKey eventChan = do+keyEventLoop :: IO [Event] -> TChan Event -> IO Event+keyEventLoop readEvents eventChan = do     -- first, see if any events are already queued up (from a key/ctrl-c     -- event or from a previous call to getEvent where we read in multiple     -- keys)    @@ -53,9 +54,15 @@             -- no events are queued yet, so fork off a thread to read keys.             -- if we receive a different type of event before it's done,             -- we'll kill it.-            tid <- forkIO (readKey eventChan)+            tid <- forkIO readerLoop             (atomically $ readTChan eventChan)                 `finally` killThread tid+  where+    readerLoop = do+        es <- readEvents+        if null es+            then readerLoop+            else atomically $ mapM_ (writeTChan eventChan) es  tryReadTChan :: TChan a -> STM (Maybe a) tryReadTChan chan = fmap Just (readTChan chan) `orElse` return Nothing@@ -66,3 +73,7 @@                 deriving (Show,Typeable,Eq)  instance Exception Interrupt where++data Layout = Layout {width, height :: Int}+                    deriving (Show,Eq)+

@@ -1,6 +1,7 @@ module System.Console.Haskeline.Vi where  import System.Console.Haskeline.Command+import System.Console.Haskeline.Key import System.Console.Haskeline.Command.Completion import System.Console.Haskeline.Command.History import System.Console.Haskeline.Command.Undo@@ -19,22 +20,22 @@                              simpleInsertions :: InputCmd InsertMode InsertMode simpleInsertions = choiceCmd-                [ KeyChar '\n' +> finish-		   , KeyChar '\r' +> finish-                   , KeyLeft +> change goLeft -                   , KeyRight +> change goRight-                   , Backspace +> change deletePrev -		   , KeyChar '\b' +> change deletePrev-                   , DeleteForward +> change deleteNext +                [ simpleChar '\n' +> finish+                   , simpleKey LeftKey +> change goLeft +                   , simpleKey RightKey +> change goRight+                   , simpleKey Backspace +> change deletePrev +                   , simpleKey Delete +> change deleteNext +                   , simpleKey Home +> change moveToStart+                   , simpleKey End +> change moveToEnd                    , changeFromChar insertChar-                   , controlKey 'l' +> clearScreenCmd-                   , controlKey 'd' +> eofIfEmpty-                   , KeyUp +> historyBack-                   , KeyDown +> historyForward+                   , ctrlChar 'l' +> clearScreenCmd+                   , ctrlChar 'd' +> eofIfEmpty+                   , simpleKey UpKey +> historyBack+                   , simpleKey DownKey +> historyForward                    , searchHistory                    , saveForUndo $ choiceCmd-                        [ KillLine +> change (deleteFromMove moveToStart)-                        , KeyChar '\t' +> completionCmd+                        [ simpleKey KillLine +> change (deleteFromMove moveToStart)+                        , simpleChar '\t' +> completionCmd                         ]                    ] @@ -46,41 +47,44 @@                     else Just $ Change s >=> continue)  startCommand :: InputCmd InsertMode InsertMode-startCommand = KeyChar '\ESC' +> change enterCommandMode+startCommand = simpleChar '\ESC' +> change enterCommandMode                     >|> viCommandActions  viCommandActions :: InputCmd CommandMode InsertMode viCommandActions = simpleCmdActions `loopUntil` exitingCommands  exitingCommands :: InputCmd CommandMode InsertMode-exitingCommands =  choiceCmd [ KeyChar 'i' +> change insertFromCommandMode-                    , KeyChar 'I' +> change (moveToStart . insertFromCommandMode)-                    , KeyChar 'a' +> change appendFromCommandMode-                    , KeyChar 'A' +> change (moveToEnd . appendFromCommandMode)-                    , KeyChar 's' +> change (insertFromCommandMode . deleteChar)+exitingCommands =  choiceCmd [ +                      simpleChar 'i' +> change insertFromCommandMode+                    , simpleChar 'I' +> change (moveToStart . insertFromCommandMode)+                    , simpleKey Home +> change (moveToStart . insertFromCommandMode)+                    , simpleChar 'a' +> change appendFromCommandMode+                    , simpleChar 'A' +> change (moveToEnd . appendFromCommandMode)+                    , simpleKey End +> change (moveToStart  . insertFromCommandMode)+                    , simpleChar 's' +> change (insertFromCommandMode . deleteChar)                     , repeated                     , saveForUndo $ choiceCmd-                        [ KeyChar 'S' +> change (const emptyIM)+                        [ simpleChar 'S' +> change (const emptyIM)                         , deleteIOnce                         ]                     ]  simpleCmdActions :: InputCmd CommandMode CommandMode-simpleCmdActions = choiceCmd [ KeyChar '\n'  +> finish-                    , KeyChar '\ESC' +> change id -- helps break out of loops-                    , controlKey 'd' +> eofIfEmpty-                    , KeyChar 'r'   +> replaceOnce -                    , KeyChar 'R'   +> loopReplace-                    , KeyChar 'x' +> change deleteChar-                    , controlKey 'l' +> clearScreenCmd-                    , KeyChar 'u' +> commandUndo-                    , controlKey 'r' +> commandRedo-                    , KeyChar '.' +> commandRedo+simpleCmdActions = choiceCmd [ simpleChar '\n'  +> finish+                    , simpleChar '\ESC' +> change id -- helps break out of loops+                    , ctrlChar 'd' +> eofIfEmpty+                    , simpleChar 'r'   +> replaceOnce +                    , simpleChar 'R'   +> loopReplace+                    , simpleChar 'x' +> change deleteChar+                    , ctrlChar 'l' +> clearScreenCmd+                    , simpleChar 'u' +> commandUndo+                    , ctrlChar 'r' +> commandRedo+                    , simpleChar '.' +> commandRedo                     , useMovements withCommandMode-                    , KeyDown +> historyForward-                    , KeyUp +> historyBack+                    , simpleKey DownKey +> historyForward+                    , simpleKey UpKey +> historyBack                     , saveForUndo $ choiceCmd-                        [ KillLine +> change (withCommandMode+                        [ simpleKey KillLine +> change (withCommandMode                                         $ deleteFromMove moveToStart)                         , deleteOnce                         ]@@ -99,35 +103,35 @@ repeated = let     start = foreachDigit startArg ['1'..'9']     addDigit = foreachDigit addNum ['0'..'9']-    deleteR = KeyChar 'd' +    deleteR = simpleChar 'd'                  >+> choiceCmd [useMovements (deleteFromRepeatedMove),-                             KeyChar 'd' +> change (const CEmpty)]-    deleteIR = KeyChar 'c'+                             simpleChar 'd' +> change (const CEmpty)]+    deleteIR = simpleChar 'c'                 >+> choiceCmd [useMovements deleteAndInsertR,-                             KeyChar 'c' +> change (const emptyIM)]+                             simpleChar 'c' +> change (const emptyIM)]     applyArg' f am = enterCommandModeRight $ applyArg f $ fmap insertFromCommandMode am     loop = choiceCmd [addDigit >|> loop                      , useMovements applyArg' >|> viCommandActions                      , saveForUndo (deleteR >|> viCommandActions)                      , saveForUndo deleteIR-                     , saveForUndo (KeyChar 'x' +> change (applyArg deleteChar)+                     , saveForUndo (simpleChar 'x' +> change (applyArg deleteChar)                         >|> viCommandActions)                      , changeWithoutKey argState >|> viCommandActions                      ]     in start >|> loop  movements :: [(Key,InsertMode -> InsertMode)]-movements = [ (KeyChar 'h', goLeft)-            , (KeyChar 'l', goRight)-            , (KeyChar 'w', skipRight isSpace . (\s -> skipRight (cmdChar s) s))-            , (KeyChar 'b', (\s -> skipLeft (cmdChar s) s) . goLeft . skipLeft isSpace)-            , (KeyChar 'W', skipRight isSpace . skipRight (not . isSpace))-            , (KeyChar 'B', skipLeft (not . isSpace) . skipLeft isSpace)-            , (KeyChar ' ', goRight)-            , (KeyLeft, goLeft)-            , (KeyRight, goRight)-            , (KeyChar '0', moveToStart)-            , (KeyChar '$', moveToEnd)+movements = [ (simpleChar 'h', goLeft)+            , (simpleChar 'l', goRight)+            , (simpleChar 'w', skipRight isSpace . (\s -> skipRight (cmdChar s) s))+            , (simpleChar 'b', (\s -> skipLeft (cmdChar s) s) . goLeft . skipLeft isSpace)+            , (simpleChar 'W', skipRight isSpace . skipRight (not . isSpace))+            , (simpleChar 'B', skipLeft (not . isSpace) . skipLeft isSpace)+            , (simpleChar ' ', goRight)+            , (simpleKey LeftKey, goLeft)+            , (simpleKey RightKey, goRight)+            , (simpleChar '0', moveToStart)+            , (simpleChar '$', moveToEnd)             ]  cmdChar :: InsertMode -> (Char -> Bool)@@ -144,14 +148,14 @@                                 movements  deleteOnce :: InputCmd CommandMode CommandMode-deleteOnce = KeyChar 'd'+deleteOnce = simpleChar 'd'             >+> choiceCmd [useMovements deleteFromCmdMove,-                         KeyChar 'd' +> change (const CEmpty)]+                         simpleChar 'd' +> change (const CEmpty)]  deleteIOnce :: InputCmd CommandMode InsertMode-deleteIOnce = KeyChar 'c'+deleteIOnce = simpleChar 'c'               >+> choiceCmd [useMovements deleteAndInsert,-                            KeyChar 'c' +> change (const emptyIM)]+                            simpleChar 'c' +> change (const emptyIM)]  deleteAndInsert :: (InsertMode -> InsertMode) -> CommandMode -> InsertMode deleteAndInsert f = insertFromCommandMode . deleteFromCmdMove f@@ -164,7 +168,7 @@ foreachDigit :: (Monad m, LineState t) => (Int -> s -> t) -> [Char]                  -> Command m s t foreachDigit f ds = choiceCmd $ map digitCmd ds-    where digitCmd d = KeyChar d +> change (f (toDigit d))+    where digitCmd d = simpleChar d +> change (f (toDigit d))           toDigit d = fromEnum d - fromEnum '0'  

@@ -1,20 +1,34 @@ module Main where  import System.Console.Haskeline+import System.Environment +{--+Testing the line-input functions and their interaction with ctrl-c signals.++Usage:+./Test          (line input)+./Test chars    (character input)+--}+ mySettings :: Settings IO mySettings = defaultSettings {historyFile = Just "myhist"}  main :: IO ()-main = runInputT mySettings $ withInterrupt $ loop 0+main = do+        args <- getArgs+        let inputFunc = case args of+                ["chars"] -> fmap (fmap (\c -> [c])) . getInputChar+                _ -> getInputLine+        runInputT mySettings $ withInterrupt $ loop inputFunc 0     where-        loop :: Int -> InputT IO ()-        loop n = do+        loop inputFunc n = do             minput <-  handleInterrupt (return (Just "Caught interrupted"))-                        $ getInputLine (show n ++ ":")+                        $ inputFunc (show n ++ ":")             case minput of                 Nothing -> return ()                 Just "quit" -> return ()+                Just "q" -> return ()                 Just s -> do                             outputStrLn ("line " ++ show n ++ ":" ++ s)-                            loop (n+1)+                            loop inputFunc (n+1)

@@ -1,6 +1,6 @@ Name:           haskeline Cabal-Version:  >=1.2-Version:        0.4+Version:        0.5 Category:       User Interfaces License:        BSD3 License-File:   LICENSE@@ -30,9 +30,10 @@         Build-depends: base < 3     else         Build-depends: base>=3 && <5 , containers>=0.1, directory>=1.0-    Build-depends:  stm>=2.0, filepath>=1.1, -                    mtl>=1.1, utf8-string>=0.3.1.1, bytestring>=0.9.0.1,-                    extensible-exceptions>=0.1.1.0+    Build-depends:  stm==2.1.*, filepath==1.1.*, mtl==1.1.*,+                    bytestring==0.9.*,+                    utf8-string==0.3.* && >=0.3.1.1,+                    extensible-exceptions==0.1.* && >=0.1.1.0     Extensions:     ForeignFunctionInterface, RankNTypes, FlexibleInstances,                 TypeSynonymInstances                 FlexibleContexts, ExistentialQuantification@@ -43,8 +44,9 @@     Exposed-Modules:                 System.Console.Haskeline                 System.Console.Haskeline.Completion-                System.Console.Haskeline.Prefs                 System.Console.Haskeline.MonadException+                System.Console.Haskeline.History+                System.Console.Haskeline.IO     Other-Modules:                 System.Console.Haskeline.Backend                 System.Console.Haskeline.Command@@ -52,8 +54,10 @@                 System.Console.Haskeline.Command.History                 System.Console.Haskeline.Emacs                 System.Console.Haskeline.InputT+                System.Console.Haskeline.Key                 System.Console.Haskeline.LineState                 System.Console.Haskeline.Monads+                System.Console.Haskeline.Prefs                 System.Console.Haskeline.Term                 System.Console.Haskeline.Command.Undo                 System.Console.Haskeline.Vi@@ -66,7 +70,8 @@         install-includes: win_console.h         cpp-options: -DMINGW     } else {-        Build-depends: terminfo>=0.2.2, unix>=2.0+        Build-depends: terminfo==0.3.*, unix==2.2.* || ==2.3.*+                        -- unix-2.3 doesn't build on ghc-6.8.1         Other-modules:                  System.Console.Haskeline.Backend.Posix                 System.Console.Haskeline.Backend.DumbTerm