haskeline 0.7.5.0 → 0.8.5.0
raw patch · 38 files changed
Files
- Changelog +83/−1
- LICENSE +14/−11
- System/Console/Haskeline.hs +75/−29
- System/Console/Haskeline/Backend.hs +17/−5
- System/Console/Haskeline/Backend/DumbTerm.hs +5/−3
- System/Console/Haskeline/Backend/Posix.hsc +138/−41
- System/Console/Haskeline/Backend/Posix/Encoder.hs +3/−2
- System/Console/Haskeline/Backend/Terminfo.hs +11/−9
- System/Console/Haskeline/Backend/WCWidth.hs +2/−2
- System/Console/Haskeline/Backend/Win32.hsc +51/−18
- System/Console/Haskeline/Backend/Win32/Echo.hs +28/−6
- System/Console/Haskeline/Command.hs +20/−21
- System/Console/Haskeline/Command/Completion.hs +16/−15
- System/Console/Haskeline/Command/History.hs +13/−8
- System/Console/Haskeline/Command/KillRing.hs +12/−12
- System/Console/Haskeline/Command/Undo.hs +2/−3
- System/Console/Haskeline/Completion.hs +32/−11
- System/Console/Haskeline/Emacs.hs +10/−3
- System/Console/Haskeline/IO.hs +1/−0
- System/Console/Haskeline/InputT.hs +112/−17
- System/Console/Haskeline/Internal.hs +47/−0
- System/Console/Haskeline/Key.hs +48/−8
- System/Console/Haskeline/LineState.hs +15/−16
- System/Console/Haskeline/MonadException.hs +0/−180
- System/Console/Haskeline/Monads.hs +8/−53
- System/Console/Haskeline/Prefs.hs +16/−3
- System/Console/Haskeline/ReaderT.hs +133/−0
- System/Console/Haskeline/RunCommand.hs +7/−5
- System/Console/Haskeline/Term.hs +17/−9
- System/Console/Haskeline/Vi.hs +202/−146
- cbits/h_wcwidth.c +2/−2
- examples/Test.hs +123/−26
- haskeline.cabal +82/−18
- includes/h_iconv.h +0/−9
- includes/windows_cconv.h +0/−12
- tests/Pty.hs +98/−0
- tests/RunTTY.hs +116/−0
- tests/Unit.hs +374/−0
Changelog view
@@ -1,3 +1,85 @@+Changed in version 8.4.5.0:++ * System.Console.Haskeline.Internal now exposes far more internals of+ Haskeline.++ * Added `useTermHandles` and `useTermHandlesWith` Behaviors for driving+ Haskeline against caller-supplied input/output handles (e.g. a serial+ console or a PTY pair other than the controlling terminal). POSIX only.++ * On POSIX, fixed escape sequences breaking when their bytes arrive in+ separate reads (e.g. on slow serial links). Added `keyseqTimeoutMs`+ to `Prefs` to configure the wait, mirroring GNU Readline's+ `keyseq-timeout`.++Changed in version 0.8.4.1:++ * Implemented ; and , movements and enabled them for d, c, and y actions.++ * Internal refactoring of f, F, t, T commands to allow implementation of ;+ and , commands.++Changed in version 0.8.4.0:++ * On Windows, when terminal-style and printing output, no longer skips+ `"\ESC...\STX"` sequences. (If used with legacy ConHost directly (for+ example, `conhost.exe cmd.exe`), it will require ConHost's ANSI-capability+ to be enabled separately.) (#126)++ * Added `System.Console.Haskeline.ReaderT` module for `ReaderT` interface.++ * `System.Console.Haskeline.Completion.listFiles` now returns a sorted list.++Changed in version 0.8.3.0:++ * User preferences are now read from $XDG_CONFIG_HOME/haskeline/haskeline.++Changed in version 0.8.2.1:+ * Add `configure` check for `termios.h` and fallbacks for wasi.++Changed in version 0.8.2:+ * Add versions of `completeWord{,withPrev}` that take predicates for word break chars (#164)++Changed in version 0.8.1.3:+ * Use the capi calling convention for ioctl (#163).++Changed in version 0.8.1.2:+ * Add import list to Data.List (#153)++Changed in version 0.8.1.1:+ * Allow bytestring-0.11 and base-4.16+ * Fix name conflicts with Win32-2.9 (#145)++Changed in version 0.8.1.0:+ * Use grapheme's width to align a list of completions (#143)+ * Add withRunInBase to help decompose InputT (#131)+ * Add support for WINIO to haskeline. (#140)+ * Allow base-4.15+ * Eta expand as required by simplified subsumption rules in newer GHC+ * Remove unused iconv cbits (#135)+ * Support non-BMP characters (or, surrogate pairs) on Windows (#125)++Changed in version 0.8.0.1:+ * Add a Cabal flag to disable the example executable as well as+ the test that uses it.++Changed in version 0.8.0.0:+ * Breaking changes:+ * Add a `MonadFail` instance for `InputT`.+ * Switch the LICENSE file from BSD2 to BSD3, to be consistent+ with the .cabal file.+ * Backwards-compatible changes+ * Improve the documentation around when input functions return+ `Nothing`.+ * Allow binding keys to incremental search, as+ `ReverseSearchHistory` and `ForwardSearchHistory`.+ * Handling `STX`-wrapped control sequences on any lines of the+ prompt, not just the last one.+ * Add `debugTerminalKeys` to help debug input problems+ * Add `waitForAnyKey` to wait for a single key press.+ * Define test targest in the .cabal file+ * Bump the upper bound to base-4.15.+ Changed in version 0.7.5.0: * Add the new function `fallbackCompletion` to combine multiple `CompletionFunc`s@@ -47,7 +129,7 @@ * Fix build on Windows. Changed in version 0.7.2.0:- * Bump upper-bound on base and filepath libraries to accomodate GHC HEAD (7.10)+ * Bump upper-bound on base and filepath libraries to accommodate GHC HEAD (7.10) * Drop Cabal dependency to 1.10 * Use explicit forall syntax to avoid warning * Support Applicative/Monad proposal in Win32/Draw backend
LICENSE view
@@ -1,23 +1,26 @@-Copyright 2007-2009, Judah Jacobson.-All Rights Reserved.+Copyright 2007 Judah Jacobson Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -- Redistribution of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.+1. Redistributions of source code must retain the above copyright notice, this+list of conditions and the following disclaimer. -- Redistribution in binary form must reproduce the above copyright notice,+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. -THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+3. Neither the name of the copyright holder nor the names of its contributors+may be used to endorse or promote products derived from this software without+specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,-OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE-USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
System/Console/Haskeline.hs view
@@ -39,6 +39,10 @@ defaultBehavior, useFileHandle, useFile,+#ifndef MINGW+ useTermHandles,+ useTermHandlesWith,+#endif preferTerm, -- * User interaction functions -- ** Reading user input@@ -47,6 +51,7 @@ getInputLineWithInitial, getInputChar, getPassword,+ waitForAnyKey, -- ** Outputting text -- $outputfncs outputStr,@@ -59,10 +64,12 @@ setComplete, -- ** User preferences Prefs(),+ keyseqTimeoutMs, readPrefs, defaultPrefs, runInputTWithPrefs, runInputTBehaviorWithPrefs,+ withRunInBase, -- ** History -- $history getHistory,@@ -73,8 +80,7 @@ Interrupt(..), handleInterrupt, -- * Additional submodules- module System.Console.Haskeline.Completion,- module System.Console.Haskeline.MonadException)+ module System.Console.Haskeline.Completion) where import System.Console.Haskeline.LineState@@ -84,15 +90,17 @@ 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.Console.Haskeline.RunCommand -import System.IO+import Control.Monad ((>=>))+import Control.Monad.Catch (MonadMask, handle) import Data.Char (isSpace, isPrint)+import Data.Maybe (isJust)+import System.IO -- | A useful default. In particular:@@ -128,11 +136,13 @@ {- $inputfncs The following functions read one line or character of input from the user. -When using terminal-style interaction, these functions return 'Nothing' if the user-pressed @Ctrl-D@ when the input text was empty.+They return `Nothing` if they encounter the end of input. More specifically: -When using file-style interaction, these functions return 'Nothing' if-an @EOF@ was encountered before any characters were read.+- When using terminal-style interaction, they return `Nothing` if the user+ pressed @Ctrl-D@ when the input text was empty.++- When using file-style interaction, they return `Nothing` if an @EOF@ was+ encountered before any characters were read. -} @@ -140,8 +150,13 @@ If @'autoAddHistory' == 'True'@ and the line input is nonblank (i.e., is not all spaces), it will be automatically added to the history.++To include ANSI escape sequences in the input prompt, terminate them by @\STX@.+See <https://github.com/haskell/haskeline/wiki/ControlSequencesInPrompt> for+more information. -}-getInputLine :: MonadException m => String -- ^ The input prompt+getInputLine :: (MonadIO m, MonadMask m)+ => String -- ^ The input prompt -> InputT m (Maybe String) getInputLine = promptedInput (getInputCmdLine emptyIM) $ runMaybeT . getLocaleLine @@ -160,7 +175,7 @@ > getInputLineWithInitial "prompt> " ("left", "") -- The cursor starts at the end of the line. > getInputLineWithInitial "prompt> " ("left ", "right") -- The cursor starts before the second word. -}-getInputLineWithInitial :: MonadException m+getInputLineWithInitial :: (MonadIO m, MonadMask m) => String -- ^ The input prompt -> (String, String) -- ^ The initial value left and right of the cursor -> InputT m (Maybe String)@@ -169,7 +184,7 @@ where initialIM = insertString left $ moveToStart $ insertString right $ emptyIM -getInputCmdLine :: MonadException m => InsertMode -> TermOps -> String -> InputT m (Maybe String)+getInputCmdLine :: (MonadIO m, MonadMask m) => InsertMode -> TermOps -> Prefix -> InputT m (Maybe String) getInputCmdLine initialIM tops prefix = do emode <- InputT $ asks editMode result <- runInputCmdT tops $ case emode of@@ -202,7 +217,7 @@ When using file-style interaction, a newline will be read if it is immediately available after the input character. -}-getInputChar :: MonadException m => String -- ^ The input prompt+getInputChar :: (MonadIO m, MonadMask m) => String -- ^ The input prompt -> InputT m (Maybe Char) getInputChar = promptedInput getInputCmdChar $ \fops -> do c <- getPrintableChar fops@@ -216,18 +231,44 @@ Just False -> getPrintableChar fops _ -> return c -getInputCmdChar :: MonadException m => TermOps -> String -> InputT m (Maybe Char)+getInputCmdChar :: (MonadIO m, MonadMask m) => TermOps -> Prefix -> InputT m (Maybe Char) getInputCmdChar tops prefix = runInputCmdT tops $ runCommandLoop tops prefix acceptOneChar emptyIM acceptOneChar :: Monad m => KeyCommand m InsertMode (Maybe Char) acceptOneChar = choiceCmd [useChar $ \c s -> change (insertChar c) s >> return (Just c)- , ctrlChar 'l' +> clearScreenCmd >|>+ , ctrlChar 'l' +> clearScreenCmd >=> keyCommand acceptOneChar , ctrlChar 'd' +> failCmd] ----------+{- | Waits for one key to be pressed, then returns. Ignores the value+of the specific key.++Returns 'True' if it successfully accepted one key. Returns 'False'+if it encountered the end of input; i.e., an @EOF@ in file-style interaction,+or a @Ctrl-D@ in terminal-style interaction.++When using file-style interaction, consumes a single character from the input which may+be non-printable.+-}+waitForAnyKey :: (MonadIO m, MonadMask m)+ => String -- ^ The input prompt+ -> InputT m Bool+waitForAnyKey = promptedInput getAnyKeyCmd+ $ \fops -> fmap isJust . runMaybeT $ getLocaleChar fops++getAnyKeyCmd :: (MonadIO m, MonadMask m) => TermOps -> Prefix -> InputT m Bool+getAnyKeyCmd tops prefix = runInputCmdT tops+ $ runCommandLoop tops prefix acceptAnyChar emptyIM+ where+ acceptAnyChar = choiceCmd+ [ ctrlChar 'd' +> const (return False)+ , KeyMap $ const $ Just (Consumed $ const $ return True)+ ]++---------- -- Passwords {- | Reads one line of input, without displaying the input while it is being typed.@@ -241,7 +282,7 @@ consoles (such as Cygwin or MSYS). -} -getPassword :: MonadException m => Maybe Char -- ^ A masking character; e.g., @Just \'*\'@+getPassword :: (MonadIO m, MonadMask m) => Maybe Char -- ^ A masking character; e.g., @Just \'*\'@ -> String -> InputT m (Maybe String) getPassword x = promptedInput (\tops prefix -> runInputCmdT tops@@ -251,12 +292,12 @@ where loop = choiceCmd [ simpleChar '\n' +> finish , simpleKey Backspace +> change deletePasswordChar- >|> loop'- , useChar $ \c -> change (addPasswordChar c) >|> loop'+ >=> loop'+ , useChar $ \c -> change (addPasswordChar c) >=> loop' , ctrlChar 'd' +> \p -> if null (passwordState p) then failCmd p else finish p- , ctrlChar 'l' +> clearScreenCmd >|> loop'+ , ctrlChar 'l' +> clearScreenCmd >=> loop' ] loop' = keyCommand loop @@ -273,7 +314,7 @@ -- | Wrapper for input functions. -- This is the function that calls "wrapFileInput" around file backend input -- functions (see Term.hs).-promptedInput :: MonadIO m => (TermOps -> String -> InputT m a)+promptedInput :: MonadIO m => (TermOps -> Prefix -> InputT m a) -> (FileOps -> IO a) -> String -> InputT m a promptedInput doTerm doFile prompt = do@@ -286,16 +327,20 @@ putStrOut rterm prompt wrapFileInput fops $ doFile fops Left tops -> do+ -- Convert the full prompt to graphemes (not just the last line)+ -- to account for the `\ESC...STX` appearing anywhere in it.+ let prompt' = stringToGraphemes prompt -- If the prompt contains newlines, print all but the last line.- let (lastLine,rest) = break (`elem` "\r\n") $ reverse prompt- outputStr $ reverse rest+ let (lastLine,rest) = break (`elem` stringToGraphemes "\r\n")+ $ reverse prompt'+ outputStr $ graphemesToString $ 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.")+> tryAction = handleInterrupt (outputStrLn "Cancelled.") > $ withInterrupt $ someLongAction The action can handle the interrupt itself; a new 'Interrupt' exception will be thrown@@ -303,7 +348,7 @@ > tryAction :: InputT IO () > tryAction = withInterrupt loop-> where loop = handle (\Interrupt -> outputStrLn "Cancelled; try again." >> loop)+> where loop = handleInterrupt (outputStrLn "Cancelled; try again." >> loop) > someLongAction This behavior differs from GHC's built-in Ctrl-C handling, which@@ -311,21 +356,22 @@ Ctrl-C. -}-withInterrupt :: MonadException m => InputT m a -> InputT m a+withInterrupt :: (MonadIO m, MonadMask m) => InputT m a -> InputT m a withInterrupt act = do rterm <- InputT ask- liftIOOp_ (wrapInterrupt rterm) act+ wrapInterrupt rterm act --- | Catch and handle an exception of type 'Interrupt'.+-- | Catch and handle an exception of type 'Interrupt'. See 'withInterrupt' for+-- more explanation. ----- > handleInterrupt f = handle $ \Interrupt -> f-handleInterrupt :: MonadException m => m a -> m a -> m a+-- > handleInterrupt (outputStrLn "Ctrl+C was pressed, aborting!") someLongAction+handleInterrupt :: MonadMask m => m a -> m a -> m a handleInterrupt f = handle $ \Interrupt -> f {- | Return a printing function, which in terminal-style interactions is thread-safe and may be run concurrently with user input without affecting the prompt. -}-getExternalPrint :: MonadException m => InputT m (String -> IO ())+getExternalPrint :: MonadIO m => InputT m (String -> IO ()) getExternalPrint = do rterm <- InputT ask return $ case termOps rterm of
System/Console/Haskeline/Backend.hs view
@@ -23,27 +23,39 @@ terminalRunTerm :: IO RunTerm terminalRunTerm = directTTY `orElse` fileHandleRunTerm stdin +#ifndef MINGW+useTermHandlesRunTerm :: Maybe String -> Handle -> Handle -> IO RunTerm+useTermHandlesRunTerm termtype input output =+ explicitTTY termtype input output `orElse` fileHandleRunTerm input+#endif+ stdinTTY :: MaybeT IO RunTerm #ifdef MINGW stdinTTY = win32TermStdin #else-stdinTTY = stdinTTYHandles >>= runDraw+stdinTTY = stdinTTYHandles >>= runDraw Nothing #endif directTTY :: MaybeT IO RunTerm #ifdef MINGW directTTY = win32Term #else-directTTY = ttyHandles >>= runDraw+directTTY = ttyHandles >>= runDraw Nothing #endif +#ifndef MINGW+explicitTTY :: Maybe String -> Handle -> Handle -> MaybeT IO RunTerm+explicitTTY termtype input output =+ explicitTTYHandles input output >>= runDraw termtype+#endif + #ifndef MINGW-runDraw :: Handles -> MaybeT IO RunTerm+runDraw :: Maybe String -> Handles -> MaybeT IO RunTerm #ifndef TERMINFO-runDraw = runDumbTerm+runDraw _termtype = runDumbTerm #else-runDraw h = runTerminfoDraw h `mplus` runDumbTerm h+runDraw termtype h = runTerminfoDraw termtype h `mplus` runDumbTerm h #endif #endif
System/Console/Haskeline/Backend/DumbTerm.hs view
@@ -9,6 +9,7 @@ import System.IO import Control.Applicative(Applicative) import Control.Monad(liftM)+import Control.Monad.Catch -- TODO: ---- Put "<" and ">" at end of term if scrolls off.@@ -21,7 +22,8 @@ initWindow = Window {pos=0} newtype DumbTerm m a = DumbTerm {unDumbTerm :: StateT Window (PosixT m) a}- deriving (Functor, Applicative, Monad, MonadIO, MonadException,+ deriving (Functor, Applicative, Monad, MonadIO,+ MonadThrow, MonadCatch, MonadMask, MonadState Window, MonadReader Handles) type DumbTermM a = forall m . (MonadIO m, MonadReader Layout m) => DumbTerm m a@@ -35,9 +37,9 @@ runDumbTerm :: Handles -> MaybeT IO RunTerm runDumbTerm h = liftIO $ posixRunTerm h (posixLayouts h) [] id evalDumb -instance (MonadException m, MonadReader Layout m) => Term (DumbTerm m) where+instance (MonadIO m, MonadMask m, MonadReader Layout m) => Term (DumbTerm m) where reposition _ s = refitLine s- drawLineDiff = drawLineDiff'+ drawLineDiff x y = drawLineDiff' x y printLines = mapM_ (printText . (++ crlf)) moveToNextLine _ = printText crlf
System/Console/Haskeline/Backend/Posix.hsc view
@@ -1,3 +1,5 @@+{-# LANGUAGE CApiFFI #-}+ module System.Console.Haskeline.Backend.Posix ( withPosixGetEvent, posixLayouts,@@ -9,6 +11,7 @@ mapLines, stdinTTYHandles, ttyHandles,+ explicitTTYHandles, posixRunTerm, fileRunTerm ) where@@ -17,17 +20,19 @@ import Foreign.C.Types import qualified Data.Map as Map import System.Posix.Terminal hiding (Interrupt)+import Control.Exception (throwTo) import Control.Monad+import Control.Monad.Catch (MonadMask, handle, finally) import Control.Concurrent.STM import Control.Concurrent hiding (throwTo) import Data.Maybe (catMaybes) import System.Posix.Signals.Exts import System.Posix.Types(Fd(..))-import Data.List+import Data.Foldable (foldl') import System.IO import System.Environment -import System.Console.Haskeline.Monads hiding (Handler)+import System.Console.Haskeline.Monads import System.Console.Haskeline.Key import System.Console.Haskeline.Term as Term import System.Console.Haskeline.Prefs@@ -47,6 +52,8 @@ #endif #include <sys/ioctl.h> +#include <HsBaseConfig.h>+ ----------------------------------------------- -- Input/output handles data Handles = Handles {hIn, hOut :: ExternalHandle@@ -59,7 +66,11 @@ ------------------- -- Window size -foreign import ccall ioctl :: FD -> CULong -> Ptr a -> IO CInt+#if !defined(HAVE_TERMIOS_H)+posixLayouts :: Handles -> [IO (Maybe Layout)]+posixLayouts _ = error "System.Console.Haskeline.Backend.Posix.posixLayouts"+#else+foreign import capi "sys/ioctl.h ioctl" ioctl :: FD -> CULong -> Ptr a -> IO CInt posixLayouts :: Handles -> [IO (Maybe Layout)] posixLayouts h = [ioctlLayout $ ehOut h, envLayout]@@ -74,6 +85,8 @@ then return $ Just Layout {height=fromEnum rows,width=fromEnum cols} else return Nothing +#endif+ unsafeHandleToFD :: Handle -> IO FD unsafeHandleToFD h = withHandle_ "unsafeHandleToFd" h $ \Handle__{haDevice=dev} -> do@@ -137,7 +150,7 @@ -- Terminal.app: ,("\ESC[5D", ctrlKey $ simpleKey LeftKey) ,("\ESC[5C", ctrlKey $ simpleKey RightKey)- -- rxvt: (Note: these will be superceded by e.g. xterm-color,+ -- rxvt: (Note: these will be superseded by e.g. xterm-color, -- which uses them as regular arrow keys.) ,("\ESC[OD", ctrlKey $ simpleKey LeftKey) ,("\ESC[OC", ctrlKey $ simpleKey RightKey)@@ -189,63 +202,138 @@ = metaKey k : ks lexKeys baseMap (c:cs) = simpleChar c : lexKeys baseMap cs -lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key,[Char])-lookupChars _ [] = Nothing-lookupChars (TreeMap tm) (c:cs) = case Map.lookup c tm of- Nothing -> Nothing- Just (Nothing,t) -> lookupChars t cs- Just (Just k, t@(TreeMap tm2))- | not (null cs) && not (Map.null tm2) -- ?? lookup d tm2?- -> lookupChars t cs- | otherwise -> Just (k, cs)+-- | Walk @cs@ through the tree, returning the /longest/ key found along+-- the path together with whatever bytes follow it.+--+-- If a longer match is attempted but doesn't pan out (the next byte+-- isn't in the deeper subtree), we fall back to the most recent shorter+-- key we passed. This avoids the well-known sharp edge where input+-- like @\\ESC[AC@ — with @\\ESC[A@ registered (up-arrow) and the @A@+-- node having children that don't include @C@ — would previously be+-- reported as no match at all, instead of @up-arrow + 'C'@.+--+-- 'Nothing' is returned only when no key is reached anywhere along the+-- walk.+lookupChars :: TreeMap Char Key -> [Char] -> Maybe (Key, [Char])+lookupChars _ [] = Nothing+lookupChars tree cs = go Nothing tree cs+ where+ -- 'best' holds the longest committed match so far (or Nothing if+ -- we haven't passed a key node yet). When the next byte doesn't+ -- extend the path we return 'best'.+ go best (TreeMap m) (c:cs') = case Map.lookup c m of+ Nothing -> best+ Just (mKey, sub) ->+ let best' = maybe best (\k -> Just (k, cs')) mKey+ in case cs' of+ _:_ -> go best' sub cs'+ [] -> best'+ go best _ [] = best -- unreachable: top-level [] handled above +-- | Greedily peel complete keys off the front of @cs@. Returns the+-- decoded keys (in forward order) and the leftover bytes that didn't+-- (yet) form a complete tree match.+peelCompleteKeys :: TreeMap Char Key -> [Char] -> ([Key], [Char])+peelCompleteKeys tree = go id+ where+ go acc cs = case lookupChars tree cs of+ Just (k, rest) -> go (acc . (k:)) rest+ Nothing -> (acc [], cs)++-- | True if @cs@ matches a /strict/ (non-terminal) prefix of some path+-- in the @TreeMap@ — i.e. it could still be extended into a complete+-- key sequence if more bytes arrive.+isStrictTreePrefix :: TreeMap Char b -> [Char] -> Bool+isStrictTreePrefix _ [] = False+isStrictTreePrefix (TreeMap m) (c:cs) = case Map.lookup c m of+ Nothing -> False+ Just (_, sub@(TreeMap sm)) -> case cs of+ [] -> not (Map.null sm)+ _ -> isStrictTreePrefix sub cs+ ----------------------------- -withPosixGetEvent :: (MonadException m, MonadReader Prefs m)+withPosixGetEvent :: (MonadIO m, MonadMask m, MonadReader Prefs m) => TChan Event -> Handles -> [(String,Key)] -> (m Event -> m a) -> m a withPosixGetEvent eventChan h termKeys f = wrapTerminalOps h $ do baseMap <- getKeySequences (ehIn h) termKeys+ timeoutMs <- asks (fromIntegral . keyseqTimeoutMs :: Prefs -> Int) withWindowHandler eventChan- $ f $ liftIO $ getEvent (ehIn h) baseMap eventChan+ $ f $ liftIO $ getEvent (ehIn h) timeoutMs baseMap eventChan -withWindowHandler :: MonadException m => TChan Event -> m a -> m a+withWindowHandler :: (MonadIO m, MonadMask m) => TChan Event -> m a -> m a withWindowHandler eventChan = withHandler windowChange $ Catch $ atomically $ writeTChan eventChan WindowResize -withSigIntHandler :: MonadException m => m a -> m a+withSigIntHandler :: (MonadIO m, MonadMask 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 :: (MonadIO m, MonadMask m) => Signal -> Handler -> m a -> m a withHandler signal handler f = do old_handler <- liftIO $ installHandler signal handler Nothing f `finally` liftIO (installHandler signal old_handler Nothing) -getEvent :: Handle -> TreeMap Char Key -> TChan Event -> IO Event-getEvent h baseMap = keyEventLoop $ do- cs <- getBlockOfChars h- return [KeyInput $ lexKeys baseMap cs]+getEvent :: Handle -> Int -> TreeMap Char Key -> TChan Event -> IO Event+getEvent h timeoutMs baseMap = keyEventLoop $ do+ ks <- getBlockOfKeys h baseMap timeoutMs+ return [KeyInput ks] --- Read at least one character of input, and more if immediately--- available. In particular the characters making up a control sequence--- will all be available at once, so they can be processed together--- (with Posix.lexKeys).-getBlockOfChars :: Handle -> IO String-getBlockOfChars h = do+-- | Read at least one key of input, and more if available.+--+-- A multi-byte control sequence (e.g. @\\ESC[A@ for arrow-up) may not+-- arrive in a single read on a slow link such as a low-bandwidth serial+-- port: the @\\ESC@ can land before the @[A@. When the buffer ends in+-- bytes that are a strict prefix of some known key sequence, we wait up+-- to @timeoutMs@ for the rest before returning. Otherwise we return as+-- soon as nothing more is buffered. This mirrors GNU Readline's+-- @keyseq-timeout@.+--+-- The loop tracks bytes and decoded keys side by side: every time we+-- run out of immediately-available input we peel complete keys from the+-- front of the byte buffer and shrink it down to just its trailing+-- (possibly partial) prefix. That keeps the per-decision work bounded+-- by the size of the in-flight sequence rather than the whole accrued+-- buffer, which matters when bytes trickle in slowly.+--+-- Win32 is unaffected: that backend reads structured @INPUT_RECORD@+-- key events rather than raw bytes, so escape sequences are never+-- fragmented in the first place.+getBlockOfKeys :: Handle -> TreeMap Char Key -> Int -> IO [Key]+getBlockOfKeys h baseMap timeoutMs = do c <- hGetChar h- loop [c]+ loop [c] [] where- loop cs = do- isReady <- hReady h- if not isReady- then return $ reverse cs- else do- c <- hGetChar h- loop (c:cs)+ -- Both lists hold values in reverse (newest first) so that consing a+ -- new element is O(1). We reverse only at decision points or on+ -- return.+ loop bytesRev keysRev = do+ ready <- hWaitForInput h 0+ if ready+ then do+ c <- hGetChar h+ loop (c:bytesRev) keysRev+ else+ -- Drain whatever complete keys are sitting at the head of+ -- the byte buffer; what's left is either empty (done) or a+ -- still-in-flight partial sequence.+ let (peeled, partial) = peelCompleteKeys baseMap (reverse bytesRev)+ keysRev' = reverse peeled ++ keysRev+ in if null partial+ then pure (reverse keysRev')+ else if isStrictTreePrefix baseMap partial+ then do+ arrived <- hWaitForInput h timeoutMs+ if arrived+ then do+ c <- hGetChar h+ loop (c : reverse partial) keysRev'+ else pure (reverse keysRev' ++ lexKeys baseMap partial)+ else pure (reverse keysRev' ++ lexKeys baseMap partial) stdinTTYHandles, ttyHandles :: MaybeT IO Handles stdinTTYHandles = do@@ -274,13 +362,22 @@ openTerm mode = handle (\(_::IOException) -> mzero) $ liftIO $ openInCodingMode "/dev/tty" mode +explicitTTYHandles :: Handle -> Handle -> MaybeT IO Handles+explicitTTYHandles h_in h_out = do+ isInTerm <- liftIO $ hIsTerminalDevice h_in+ guard isInTerm+ return Handles+ { hIn = externalHandle h_in+ , hOut = externalHandle h_out+ , closeHandles = return ()+ } posixRunTerm :: Handles -> [IO (Maybe Layout)] -> [(String,Key)]- -> (forall m b . MonadException m => m b -> m b)- -> (forall m . (MonadException m, CommandMonad m) => EvalTerm (PosixT m))+ -> (forall m b . (MonadIO m, MonadMask m) => m b -> m b)+ -> (forall m . (MonadMask m, CommandMonad m) => EvalTerm (PosixT m)) -> IO RunTerm posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do ch <- newTChanIO@@ -336,7 +433,7 @@ -- NOTE: If we set stdout to NoBuffering, there can be a flicker effect when many -- characters are printed at once. We'll keep it buffered here, and let the Draw -- monad manually flush outputs that don't print a newline.-wrapTerminalOps :: MonadException m => Handles -> m a -> m a+wrapTerminalOps :: (MonadIO m, MonadMask m) => Handles -> m a -> m a wrapTerminalOps hs = bracketSet (hGetBuffering h_in) (hSetBuffering h_in) NoBuffering -- TODO: block buffering? Certain \r and \n's are causing flicker...@@ -344,8 +441,8 @@ -- - breaking line after offset widechar? . bracketSet (hGetBuffering h_out) (hSetBuffering h_out) LineBuffering . bracketSet (hGetEcho h_in) (hSetEcho h_in) False- . liftIOOp_ (withCodingMode $ hIn hs)- . liftIOOp_ (withCodingMode $ hOut hs)+ . withCodingMode (hIn hs)+ . withCodingMode (hOut hs) where h_in = ehIn hs h_out = ehOut hs
System/Console/Haskeline/Backend/Posix/Encoder.hs view
@@ -13,6 +13,7 @@ openInCodingMode, ) where +import Control.Monad.Catch (MonadMask, bracket) import System.IO import System.Console.Haskeline.Monads @@ -41,13 +42,13 @@ -- | Use to ensure that an external handle is in the correct mode -- for the duration of the given action.-withCodingMode :: ExternalHandle -> IO a -> IO a+withCodingMode :: (MonadIO m, MonadMask m) => ExternalHandle -> m a -> m a withCodingMode ExternalHandle {externalMode=CodingMode} act = act withCodingMode (ExternalHandle OtherMode h) act = do bracket (liftIO $ hGetEncoding h) (liftIO . hSetBinOrEncoding h) $ const $ do- hSetEncoding h haskelineEncoding+ liftIO $ hSetEncoding h haskelineEncoding act hSetBinOrEncoding :: Handle -> Maybe TextEncoding -> IO ()
System/Console/Haskeline/Backend/Terminfo.hs view
@@ -1,4 +1,4 @@-#if __GLASGOW_HASKELL__ <= 802+#if __GLASGOW_HASKELL__ < 802 {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif module System.Console.Haskeline.Backend.Terminfo(@@ -9,6 +9,7 @@ import System.Console.Terminfo import Control.Monad+import Control.Monad.Catch import Data.List(foldl') import System.IO import qualified Control.Exception as Exception@@ -105,7 +106,8 @@ (StateT TermRows (StateT TermPos (PosixT m))))) a}- deriving (Functor, Applicative, Monad, MonadIO, MonadException,+ deriving (Functor, Applicative, Monad, MonadIO,+ MonadMask, MonadThrow, MonadCatch, MonadReader Actions, MonadReader Terminal, MonadState TermPos, MonadState TermRows, MonadReader Handles) @@ -123,9 +125,9 @@ . unDraw -runTerminfoDraw :: Handles -> MaybeT IO RunTerm-runTerminfoDraw h = do- mterm <- liftIO $ Exception.try setupTermFromEnv+runTerminfoDraw :: Maybe String -> Handles -> MaybeT IO RunTerm+runTerminfoDraw termtype h = do+ mterm <- liftIO $ Exception.try $ maybe setupTermFromEnv setupTerm termtype case mterm of Left (_::SetupTermError) -> mzero Right term -> do@@ -136,7 +138,7 @@ (evalDraw term actions) -- If the keypad on/off capabilities are defined, wrap the computation with them.-wrapKeypad :: MonadException m => Handle -> Terminal -> m a -> m a+wrapKeypad :: (MonadIO m, MonadMask m) => Handle -> Terminal -> m a -> m a wrapKeypad h term f = (maybeOutput keypadOn >> f) `finally` maybeOutput keypadOff where@@ -200,7 +202,7 @@ -- see GHC ticket #1749). outputText :: String -> ActionM ()-outputText = output . const . termText+outputText s = output (const (termText s)) left,right,up :: Int -> TermAction left = flip leftA@@ -236,7 +238,7 @@ moveRelative :: Int -> ActionM () moveRelative n = liftM3 (advancePos n) ask get get- >>= moveToPos+ >>= \p -> moveToPos p -- Note that these move by a certain number of cells, not graphemes. changeRight, changeLeft :: Int -> ActionM ()@@ -349,7 +351,7 @@ put initTermRows drawLineDiffT ([],[]) s -instance (MonadException m, MonadReader Layout m) => Term (Draw m) where+instance (MonadIO m, MonadMask m, MonadReader Layout m) => Term (Draw m) where drawLineDiff xs ys = runActionT $ drawLineDiffT xs ys reposition layout lc = runActionT $ repositionT layout lc
System/Console/Haskeline/Backend/WCWidth.hs view
@@ -10,10 +10,10 @@ import System.Console.Haskeline.LineState -import Data.List+import Data.List (foldl') import Foreign.C.Types -foreign import ccall unsafe haskeline_mk_wcwidth :: CWchar -> CInt+foreign import ccall unsafe haskeline_mk_wcwidth :: CInt -> CInt wcwidth :: Char -> Int wcwidth c = case haskeline_mk_wcwidth $ toEnum $ fromEnum c of
System/Console/Haskeline/Backend/Win32.hsc view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module System.Console.Haskeline.Backend.Win32( win32Term, win32TermStdin,@@ -8,17 +10,41 @@ import System.IO import Foreign import Foreign.C+#if MIN_VERSION_Win32(2,14,1)+import System.Win32 hiding (+ multiByteToWideChar,+ setConsoleMode,+ getConsoleMode,+ KeyEvent,+ keyDown,+ virtualKeyCode,+ repeatCount,+ virtualScanCode,+ windowSize+ )+#elif MIN_VERSION_Win32(2,9,0)+import System.Win32 hiding (multiByteToWideChar, setConsoleMode, getConsoleMode)+#else import System.Win32 hiding (multiByteToWideChar)+#endif import Graphics.Win32.Misc(getStdHandle, sTD_OUTPUT_HANDLE) import Data.List(intercalate) import Control.Concurrent.STM import Control.Concurrent hiding (throwTo)-import Data.Char(isPrint)+import Data.Char(isPrint, chr, ord) import Data.Maybe(mapMaybe)+import Control.Exception (IOException, throwTo) import Control.Monad+import Control.Monad.Catch+ ( MonadThrow+ , MonadCatch+ , MonadMask+ , bracket+ , handle+ ) import System.Console.Haskeline.Key-import System.Console.Haskeline.Monads hiding (Handler)+import System.Console.Haskeline.Monads import System.Console.Haskeline.LineState import System.Console.Haskeline.Term import System.Console.Haskeline.Backend.WCWidth@@ -58,8 +84,16 @@ then eventReader h else do es <- readEvents h- return $ mapMaybe processEvent es+ return $ combineSurrogatePairs $ mapMaybe processEvent es +combineSurrogatePairs :: [Event] -> [Event]+combineSurrogatePairs (KeyInput [Key m1 (KeyChar c1)] : KeyInput [Key _ (KeyChar c2)] : es)+ | 0xD800 <= ord c1 && ord c1 < 0xDC00 && 0xDC00 <= ord c2 && ord c2 < 0xE000+ = let c = (((ord c1 .&. 0x3FF) `shiftL` 10) .|. (ord c2 .&. 0x3FF)) + 0x10000+ in KeyInput [Key m1 (KeyChar (chr c))] : combineSurrogatePairs es+combineSurrogatePairs (e:es) = e : combineSurrogatePairs es+combineSurrogatePairs [] = []+ consoleHandles :: MaybeT IO Handles consoleHandles = do h_in <- open "CONIN$"@@ -122,7 +156,7 @@ unicodeChar :: Char, controlKeyState :: DWORD} -- TODO: WINDOW_BUFFER_SIZE_RECORD- -- I cant figure out how the user generates them.+ -- I can't figure out how the user generates them. | WindowEvent | OtherEvent deriving Show@@ -169,9 +203,9 @@ sizeOf _ = (#size COORD) alignment _ = (#alignment COORD) peek p = do- x :: CShort <- (#peek COORD, X) p- y :: CShort <- (#peek COORD, Y) p- return Coord {coordX = fromEnum x, coordY = fromEnum y}+ cx :: CShort <- (#peek COORD, X) p+ cy :: CShort <- (#peek COORD, Y) p+ return Coord {coordX = fromEnum cx, coordY = fromEnum cy} poke p c = do (#poke COORD, X) p (toEnum (coordX c) :: CShort) (#poke COORD, Y) p (toEnum (coordY c) :: CShort)@@ -218,10 +252,10 @@ -- To be safe, we pick a round number we know to be less than the limit. limit = 20000 -- known to be less than WriteConsoleW's buffer limit writeConsole'- = withArray (map (toEnum . fromEnum) xs)- $ \t_arr -> alloca $ \numWritten -> do+ = withCWStringLen xs+ $ \(t_arr, len) -> alloca $ \numWritten -> do failIfFalse_ "WriteConsoleW"- $ c_WriteConsoleW h t_arr (toEnum $ length xs)+ $ c_WriteConsoleW h t_arr (toEnum len) numWritten nullPtr foreign import WINDOWS_CCONV "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool@@ -239,7 +273,7 @@ foreign import WINDOWS_CCONV "windows.h SetConsoleMode" c_SetConsoleMode :: HANDLE -> DWORD -> IO Bool -withWindowMode :: MonadException m => Handles -> m a -> m a+withWindowMode :: (MonadIO m, MonadMask m) => Handles -> m a -> m a withWindowMode hs f = do let h = hIn hs bracket (getConsoleMode h) (setConsoleMode h)@@ -259,7 +293,8 @@ closeHandles hs = closeHandle (hIn hs) >> closeHandle (hOut hs) newtype Draw m a = Draw {runDraw :: ReaderT Handles m a}- deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadReader Handles)+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader Handles,+ MonadThrow, MonadCatch, MonadMask) type DrawM a = forall m . (MonadIO m, MonadReader Layout m) => Draw m a @@ -345,10 +380,8 @@ crlf :: String crlf = "\r\n" -instance (MonadException m, MonadReader Layout m) => Term (Draw m) where- drawLineDiff (xs1,ys1) (xs2,ys2) = let- fixEsc = filter ((/= '\ESC') . baseChar)- in drawLineDiffWin (fixEsc xs1, fixEsc ys1) (fixEsc xs2, fixEsc ys2)+instance (MonadMask m, MonadIO m, MonadReader Layout m) => Term (Draw m) where+ drawLineDiff = drawLineDiffWin -- 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.@@ -391,7 +424,7 @@ closeHandles hs } -win32WithEvent :: MonadException m => Handles -> TChan Event+win32WithEvent :: MonadIO m => Handles -> TChan Event -> (m Event -> m a) -> m a win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan @@ -437,7 +470,7 @@ :: FunPtr Handler -> BOOL -> IO BOOL -- sets the tv to True when ctrl-c is pressed.-withCtrlCHandler :: MonadException m => m a -> m a+withCtrlCHandler :: (MonadMask m, MonadIO m) => m a -> m a withCtrlCHandler f = bracket (liftIO $ do tid <- myThreadId fp <- wrapHandler (handler tid)
System/Console/Haskeline/Backend/Win32/Echo.hs view
@@ -4,9 +4,9 @@ import Control.Exception (throw) import Control.Monad (void)-import Control.Monad.IO.Class (liftIO)+import Control.Monad.Catch (MonadMask, bracket)+import Control.Monad.IO.Class (MonadIO(..)) -import System.Console.Haskeline.MonadException (MonadException, bracket) import System.Exit (ExitCode(..)) import System.IO (Handle, hGetContents, hGetEcho, hSetEcho) import System.Process (StdStream(..), createProcess, shell,@@ -21,6 +21,10 @@ import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) import GHC.IO.FD (FD(..))+#if defined(__IO_MANAGER_WINIO__)+import GHC.IO.Handle.Windows (handleToHANDLE)+import GHC.IO.SubSystem ((<!>))+#endif import GHC.IO.Handle.Types (Handle(..), Handle__(..)) import System.Win32.Types (HANDLE)@@ -67,7 +71,7 @@ -- ('liftIO' . 'hSetInputEchoState' input) -- (const action) -- @-hBracketInputEcho :: MonadException m => Handle -> m a -> m a+hBracketInputEcho :: (MonadIO m, MonadMask m) => Handle -> m a -> m a hBracketInputEcho input action = bracket (liftIO $ hGetInputEchoState input) (liftIO . hSetInputEchoState input)@@ -76,7 +80,7 @@ -- | Perform a computation with the handle's input echoing disabled. Before -- running the computation, the handle's input 'EchoState' is saved, and the -- saved 'EchoState' is restored after the computation finishes.-hWithoutInputEcho :: MonadException m => Handle -> m a -> m a+hWithoutInputEcho :: (MonadIO m, MonadMask m) => Handle -> m a -> m a hWithoutInputEcho input action = do echo_off <- liftIO $ hEchoOff input hBracketInputEcho input@@ -145,11 +149,30 @@ -- Originally authored by Max Bolingbroke in the ansi-terminal library withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a-withHandleToHANDLE haskell_handle action =+#if defined(__IO_MANAGER_WINIO__)+withHandleToHANDLE = withHandleToHANDLEPosix <!> withHandleToHANDLENative+#else+withHandleToHANDLE = withHandleToHANDLEPosix+#endif++#if defined(__IO_MANAGER_WINIO__)+withHandleToHANDLENative :: Handle -> (HANDLE -> IO a) -> IO a+withHandleToHANDLENative haskell_handle action = -- Create a stable pointer to the Handle. This prevents the garbage collector -- getting to it while we are doing horrible manipulations with it, and hence -- stops it being finalized (and closed). withStablePtr haskell_handle $ const $ do+ windows_handle <- handleToHANDLE haskell_handle+ -- Do what the user originally wanted+ action windows_handle+#endif++withHandleToHANDLEPosix :: Handle -> (HANDLE -> IO a) -> IO a+withHandleToHANDLEPosix haskell_handle action =+ -- Create a stable pointer to the Handle. This prevents the garbage collector+ -- getting to it while we are doing horrible manipulations with it, and hence+ -- stops it being finalized (and closed).+ withStablePtr haskell_handle $ const $ do -- Grab the write handle variable from the Handle let write_handle_mvar = case haskell_handle of FileHandle _ handle_mvar -> handle_mvar@@ -162,7 +185,6 @@ -- Finally, turn that (C-land) FD into a HANDLE using msvcrt windows_handle <- c_get_osfhandle fd- -- Do what the user originally wanted action windows_handle
System/Console/Haskeline/Command.hs view
@@ -1,14 +1,13 @@ module System.Console.Haskeline.Command( -- * Commands Effect(..),- KeyMap(..), + KeyMap(..), CmdM(..), Command, KeyCommand, KeyConsumed(..), withoutConsuming, keyCommand,- (>|>), (>+>), try, effect,@@ -21,31 +20,32 @@ change, changeFromChar, (+>),+ useKey, useChar, choiceCmd, keyChoiceCmd, keyChoiceCmdM,+ doAfter, doBefore ) where import Data.Char(isPrint)-import Control.Applicative(Applicative(..))-import Control.Monad(ap, mplus, liftM)+import Control.Monad(ap, mplus, liftM, (>=>)) import Control.Monad.Trans.Class import System.Console.Haskeline.LineState import System.Console.Haskeline.Key data Effect = LineChange (Prefix -> LineChars)- | PrintLines [String]- | ClearScreen- | RingBell+ | PrintLines [String]+ | ClearScreen+ | RingBell lineChange :: LineState s => s -> Effect lineChange = LineChange . flip lineChars data KeyMap a = KeyMap {lookupKM :: Key -> Maybe (KeyConsumed a)} -data KeyConsumed a = NotConsumed a | Consumed a+data KeyConsumed a = NotConsumed a | Consumed a deriving Show instance Functor KeyMap where fmap f km = KeyMap $ fmap (fmap f) . lookupKM km@@ -55,10 +55,10 @@ fmap f (Consumed x) = Consumed (f x) -data CmdM m a = GetKey (KeyMap (CmdM m a))- | DoEffect Effect (CmdM m a)- | CmdM (m (CmdM m a))- | Result a+data CmdM m a = GetKey (KeyMap (CmdM m a))+ | DoEffect Effect (CmdM m a)+ | CmdM (m (CmdM m a))+ | Result a type Command m s t = s -> CmdM m t @@ -93,7 +93,7 @@ -- TODO: could just be a monadic action that returns a Char. useChar :: (Char -> Command m s t) -> KeyCommand m s t useChar act = KeyMap $ \k -> case k of- Key m (KeyChar c) | isPrint c && m==noModifier+ Key m (KeyChar c) | isPrint c && m == noModifier -> Just $ Consumed (act c) _ -> Nothing @@ -112,20 +112,22 @@ keyChoiceCmdM :: [KeyMap (CmdM m a)] -> CmdM m a keyChoiceCmdM = GetKey . choiceCmd -infixr 6 >|>-(>|>) :: Monad m => Command m s t -> Command m t u -> Command m s u-f >|> g = \x -> f x >>= g+doBefore :: Monad m => Command m s t -> KeyCommand m t u -> KeyCommand m s u+doBefore g km = fmap (g >=>) km +doAfter :: Monad m => KeyCommand m s t -> Command m t u -> KeyCommand m s u+doAfter km g = fmap (>=> g) km+ infixr 6 >+> (>+>) :: Monad m => KeyCommand m s t -> Command m t u -> KeyCommand m s u-km >+> g = fmap (>|> g) km+(>+>) = doAfter -- attempt to run the command (predicated on getting a valid key); but if it fails, just keep -- going. try :: Monad m => KeyCommand m s s -> Command m s s try f = keyChoiceCmd [f,withoutConsuming return] -infixr 6 +>+infixr 0 +> (+>) :: Key -> a -> KeyMap a (+>) = useKey @@ -161,6 +163,3 @@ changeFromChar :: (LineState t, Monad m) => (Char -> s -> t) -> KeyCommand m s t changeFromChar f = useChar $ change . f--doBefore :: Monad m => Command m s t -> KeyCommand m t u -> KeyCommand m s u-doBefore cmd = fmap (cmd >|>)
System/Console/Haskeline/Command/Completion.hs view
@@ -5,6 +5,7 @@ completionCmd ) where +import System.Console.Haskeline.Backend.WCWidth (gsWidth) import System.Console.Haskeline.Command import System.Console.Haskeline.Command.Undo import System.Console.Haskeline.Key@@ -14,6 +15,7 @@ import System.Console.Haskeline.Completion import System.Console.Haskeline.Monads +import Control.Monad ((>=>)) import Data.List(transpose, unfoldr) useCompletion :: InsertMode -> Completion -> InsertMode@@ -34,7 +36,7 @@ -- | Create a 'Command' for word completion. completionCmd :: (MonadState Undo m, CommandMonad m) => Key -> KeyCommand m InsertMode InsertMode-completionCmd k = k +> saveForUndo >|> \oldIM -> do+completionCmd k = k +> saveForUndo >=> \oldIM -> do (rest,cs) <- askIMCompletions oldIM case cs of [] -> effect RingBell >> return oldIM@@ -58,7 +60,7 @@ menuCompletion k = loop where loop [] = setState- loop (c:cs) = change (const c) >|> try (k +> loop cs)+ loop (c:cs) = change (const c) >=> try (k +> loop cs) makePartialCompletion :: InsertMode -> [Completion] -> InsertMode makePartialCompletion im completions = insertString partial im@@ -120,27 +122,26 @@ makeLines ws layout = let minColPad = 2 printWidth = width layout- maxLength = min printWidth (maximum (map length ws) + minColPad)- numCols = printWidth `div` maxLength- ls = if maxLength >= printWidth+ maxWidth = min printWidth (maximum (map (gsWidth . stringToGraphemes) ws) + minColPad)+ numCols = printWidth `div` maxWidth+ ls = if maxWidth >= printWidth then map (: []) ws else splitIntoGroups numCols ws- in map (padWords maxLength) ls+ in map (padWords maxWidth) ls --- Add spaces to the end of each word so that it takes up the given length.--- Don't padd the word in the last column, since printing a space in the last column+-- Add spaces to the end of each word so that it takes up the given visual width.+-- Don't pad the word in the last column, since printing a space in the last column -- causes a line wrap on some terminals. padWords :: Int -> [String] -> String padWords _ [x] = x padWords _ [] = ""-padWords len (x:xs) = x ++ replicate (len - glength x) ' '- ++ padWords len xs+padWords wid (x:xs) = x ++ replicate (wid - widthOf x) ' '+ ++ padWords wid xs where- -- kludge: compute the length in graphemes, not chars.- -- but don't use graphemes for the max length, since I'm not convinced- -- that would work correctly. (This way, the worst that can happen is- -- that columns are longer than necessary.)- glength = length . stringToGraphemes+ -- kludge: compute the width in graphemes, not chars.+ -- also use graphemes for the max width so that multi-width characters+ -- such as CJK letters are aligned correctly.+ widthOf = gsWidth . stringToGraphemes -- Split xs into rows of length n, -- such that the list increases incrementally along the columns.
System/Console/Haskeline/Command/History.hs view
@@ -5,10 +5,11 @@ import System.Console.Haskeline.Key import Control.Monad(liftM,mplus) import System.Console.Haskeline.Monads-import Data.List+import Data.List (isPrefixOf, unfoldr) import Data.Maybe(fromMaybe) import System.Console.Haskeline.History import Data.IORef+import Control.Monad.Catch data HistLog = HistLog {pastHistory, futureHistory :: [[Grapheme]]} deriving Show@@ -16,7 +17,7 @@ prevHistoryM :: [Grapheme] -> HistLog -> Maybe ([Grapheme],HistLog) prevHistoryM _ HistLog {pastHistory = []} = Nothing prevHistoryM s HistLog {pastHistory=ls:past, futureHistory=future}- = Just (ls, + = Just (ls, HistLog {pastHistory=past, futureHistory= s:future}) prevHistories :: [Grapheme] -> HistLog -> [([Grapheme],HistLog)]@@ -27,7 +28,7 @@ histLog hist = HistLog {pastHistory = map stringToGraphemes $ historyLines hist, futureHistory = []} -runHistoryFromFile :: MonadException m => Maybe FilePath -> Maybe Int+runHistoryFromFile :: (MonadIO m, MonadMask m) => Maybe FilePath -> Maybe Int -> ReaderT (IORef History) m a -> m a runHistoryFromFile Nothing _ f = do historyRef <- liftIO $ newIORef emptyHistory@@ -44,7 +45,7 @@ return x prevHistory, firstHistory :: Save s => s -> HistLog -> (s, HistLog)-prevHistory s h = let (s',h') = fromMaybe (listSave s,h) +prevHistory s h = let (s',h') = fromMaybe (listSave s,h) $ prevHistoryM (listSave s) h in (listRestore s',h') @@ -72,7 +73,7 @@ modify reverser return y where- reverser h = HistLog {futureHistory=pastHistory h, + reverser h = HistLog {futureHistory=pastHistory h, pastHistory=futureHistory h} data SearchMode = SearchMode {searchTerm :: [Grapheme],@@ -83,13 +84,17 @@ data Direction = Forward | Reverse deriving (Show,Eq) +flipDir :: Direction -> Direction+flipDir Forward = Reverse+flipDir Reverse = Forward+ directionName :: Direction -> String directionName Forward = "i-search" directionName Reverse = "reverse-i-search" instance LineState SearchMode where beforeCursor _ sm = beforeCursor prefix (foundHistory sm)- where + where prefix = stringToGraphemes ("(" ++ directionName (direction sm) ++ ")`") ++ searchTerm sm ++ stringToGraphemes "': " afterCursor = afterCursor . foundHistory@@ -104,14 +109,14 @@ startSearchMode dir im = SearchMode {searchTerm = [],foundHistory=im, direction=dir} addChar :: Char -> SearchMode -> SearchMode-addChar c s = s {searchTerm = listSave $ insertChar c +addChar c s = s {searchTerm = listSave $ insertChar c $ listRestore $ searchTerm s} searchHistories :: Direction -> [Grapheme] -> [([Grapheme],HistLog)] -> Maybe (SearchMode,HistLog) searchHistories dir text = foldr mplus Nothing . map findIt where- findIt (l,h) = do + findIt (l,h) = do im <- findInLine text l return (SearchMode text im dir,h)
System/Console/Haskeline/Command/KillRing.hs view
@@ -38,55 +38,55 @@ pasteCommand :: (Save s, MonadState KillRing m, MonadState Undo m) => ([Grapheme] -> s -> s) -> Command m (ArgMode s) s pasteCommand use = \s -> do- ms <- liftM peek get+ ms <- peek <$> get case ms of Nothing -> return $ argState s Just p -> do modify $ saveToUndo $ argState s setState $ applyArg (use p) s -deleteFromDiff' :: InsertMode -> InsertMode -> ([Grapheme],InsertMode)+deleteFromDiff' :: InsertMode -> InsertMode -> ([Grapheme], InsertMode) deleteFromDiff' (IMode xs1 ys1) (IMode xs2 ys2) | posChange >= 0 = (take posChange ys1, IMode xs1 ys2)- | otherwise = (take (negate posChange) ys2 ,IMode xs2 ys1)+ | otherwise = (take (negate posChange) ys2, IMode xs2 ys1) where posChange = length xs2 - length xs1 killFromHelper :: (MonadState KillRing m, MonadState Undo m, Save s, Save t) => KillHelper -> Command m s t-killFromHelper helper = saveForUndo >|> \oldS -> do- let (gs,newIM) = applyHelper helper (save oldS)+killFromHelper helper = saveForUndo >=> \oldS -> do+ let (gs, newIM) = applyHelper helper (save oldS) modify (push gs) setState (restore newIM) killFromArgHelper :: (MonadState KillRing m, MonadState Undo m, Save s, Save t) => KillHelper -> Command m (ArgMode s) t-killFromArgHelper helper = saveForUndo >|> \oldS -> do- let (gs,newIM) = applyArgHelper helper (fmap save oldS)+killFromArgHelper helper = saveForUndo >=> \oldS -> do+ let (gs, newIM) = applyArgHelper helper (fmap save oldS) modify (push gs) setState (restore newIM) copyFromArgHelper :: (MonadState KillRing m, Save s) => KillHelper -> Command m (ArgMode s) s copyFromArgHelper helper = \oldS -> do- let (gs,_) = applyArgHelper helper (fmap save oldS)+ let (gs, _) = applyArgHelper helper (fmap save oldS) modify (push gs) setState (argState oldS) data KillHelper = SimpleMove (InsertMode -> InsertMode)- | GenericKill (InsertMode -> ([Grapheme],InsertMode))+ | GenericKill (InsertMode -> ([Grapheme], InsertMode)) -- a generic kill gives more flexibility, but isn't repeatable.- -- for example: dd,cc, %+ -- for example: dd, cc, % killAll :: KillHelper killAll = GenericKill $ \(IMode xs ys) -> (reverse xs ++ ys, emptyIM) -applyHelper :: KillHelper -> InsertMode -> ([Grapheme],InsertMode)+applyHelper :: KillHelper -> InsertMode -> ([Grapheme], InsertMode) applyHelper (SimpleMove move) im = deleteFromDiff' im (move im) applyHelper (GenericKill act) im = act im -applyArgHelper :: KillHelper -> ArgMode InsertMode -> ([Grapheme],InsertMode)+applyArgHelper :: KillHelper -> ArgMode InsertMode -> ([Grapheme], InsertMode) applyArgHelper (SimpleMove move) im = deleteFromDiff' (argState im) (applyArg move im) applyArgHelper (GenericKill act) im = act (argState im)
System/Console/Haskeline/Command/Undo.hs view
@@ -19,7 +19,7 @@ saveToUndo :: Save s => s -> Undo -> Undo saveToUndo s undo- | not isSame = Undo {pastUndo = toSave:pastUndo undo,futureRedo=[]}+ | not isSame = Undo {pastUndo = toSave:pastUndo undo, futureRedo=[]} | otherwise = undo where toSave = save s@@ -39,7 +39,7 @@ saveForUndo :: (Save s, MonadState Undo m)- => Command m s s+ => Command m s s saveForUndo s = do modify (saveToUndo s) return s@@ -47,4 +47,3 @@ commandUndo, commandRedo :: (MonadState Undo m, Save s) => Command m s s commandUndo = simpleCommand $ liftM Right . update . undoPast commandRedo = simpleCommand $ liftM Right . update . redoFuture-
System/Console/Haskeline/Completion.hs view
@@ -6,7 +6,9 @@ fallbackCompletion, -- * Word completion completeWord,+ completeWord', completeWordWithPrev,+ completeWordWithPrev', completeQuotedWord, -- * Filename completion completeFilename,@@ -16,7 +18,7 @@ import System.FilePath-import Data.List(isPrefixOf)+import Data.List(isPrefixOf, sort) import Control.Monad(forM) import System.Console.Haskeline.Directory@@ -59,6 +61,14 @@ -> CompletionFunc m completeWord esc ws = completeWordWithPrev esc ws . const +-- | The same as 'completeWord' but takes a predicate for the whitespace characters+completeWord' :: Monad m => Maybe Char+ -- ^ An optional escape character+ -> (Char -> Bool) -- ^ Characters which count as whitespace+ -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions+ -> CompletionFunc m+completeWord' esc ws = completeWordWithPrev' esc ws . const+ -- | A custom 'CompletionFunc' which completes the word immediately to the left of the cursor, -- and takes into account the line contents to the left of the word. --@@ -71,16 +81,27 @@ -- line contents to the left of the word, reversed. The second argument is the word -- to be completed. -> CompletionFunc m-completeWordWithPrev esc ws f (line, _) = do+completeWordWithPrev esc ws = completeWordWithPrev' esc (`elem` ws)++-- | The same as 'completeWordWithPrev' but takes a predicate for the whitespace characters+completeWordWithPrev' :: Monad m => Maybe Char+ -- ^ An optional escape character+ -> (Char -> Bool) -- ^ Characters which count as whitespace+ -> (String -> String -> m [Completion])+ -- ^ Function to produce a list of possible completions. The first argument is the+ -- line contents to the left of the word, reversed. The second argument is the word+ -- to be completed.+ -> CompletionFunc m+completeWordWithPrev' esc wpred f (line, _) = do let (word,rest) = case esc of- Nothing -> break (`elem` ws) line+ Nothing -> break wpred line Just e -> escapedBreak e line completions <- f rest (reverse word)- return (rest,map (escapeReplacement esc ws) completions)+ return (rest,map (escapeReplacement esc wpred) completions) where- escapedBreak e (c:d:cs) | d == e && c `elem` (e:ws)+ escapedBreak e (c:d:cs) | d == e && (c == e || wpred c) = let (xs,ys) = escapedBreak e cs in (c:xs,ys)- escapedBreak e (c:cs) | notElem c ws+ escapedBreak e (c:cs) | not $ wpred c = let (xs,ys) = escapedBreak e cs in (c:xs,ys) escapedBreak _ cs = ("",cs) @@ -105,12 +126,12 @@ setReplacement :: (String -> String) -> Completion -> Completion setReplacement f c = c {replacement = f $ replacement c} -escapeReplacement :: Maybe Char -> String -> Completion -> Completion-escapeReplacement esc ws f = case esc of+escapeReplacement :: Maybe Char -> (Char -> Bool) -> Completion -> Completion+escapeReplacement esc wpred f = case esc of Nothing -> f Just e -> f {replacement = escape e (replacement f)} where- escape e (c:cs) | c `elem` (e:ws) = e : c : escape e cs+ escape e (c:cs) | c == e || wpred c = e : c : escape e cs | otherwise = c : escape e cs escape _ "" = "" @@ -127,7 +148,7 @@ = 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)+ return (rest, map (addQuotes . escapeReplacement esc (`elem` qs)) cs) _ -> alterative line addQuotes :: Completion -> Completion@@ -165,7 +186,7 @@ -- get all of the files in that directory, as basenames allFiles <- if not dirExists then return []- else fmap (map completion . filterPrefix)+ else fmap (sort . map completion . filterPrefix) $ getDirectoryContents fixedDir -- The replacement text should include the directory part, and also -- have a trailing slash if it's itself a directory.
System/Console/Haskeline/Emacs.hs view
@@ -1,3 +1,6 @@+#if __GLASGOW_HASKELL__ < 802+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif module System.Console.Haskeline.Emacs where import System.Console.Haskeline.Command@@ -10,10 +13,12 @@ import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT +import Control.Monad ((>=>))+import Control.Monad.Catch (MonadMask) import Data.Char -type InputCmd s t = forall m . MonadException m => Command (InputCmdT m) s t-type InputKeyCmd s t = forall m . MonadException m => KeyCommand (InputCmdT m) s t+type InputCmd s t = forall m . (MonadIO m, MonadMask m) => Command (InputCmdT m) s t+type InputKeyCmd s t = forall m . (MonadIO m, MonadMask m) => KeyCommand (InputCmdT m) s t emacsCommands :: InputKeyCmd InsertMode (Maybe String) emacsCommands = choiceCmd [@@ -28,7 +33,7 @@ deleteCharOrEOF s | s == emptyIM = return Nothing | otherwise = change deleteNext s >>= justDelete- justDelete = keyChoiceCmd [eotKey +> change deleteNext >|> justDelete+ justDelete = keyChoiceCmd [eotKey +> change deleteNext >=> justDelete , emacsCommands] @@ -42,6 +47,8 @@ , completionCmd (simpleChar '\t') , simpleKey UpKey +> historyBack , simpleKey DownKey +> historyForward+ , simpleKey SearchReverse +> searchForPrefix Reverse+ , simpleKey SearchForward +> searchForPrefix Forward , searchHistory ]
System/Console/Haskeline/IO.hs view
@@ -42,6 +42,7 @@ import System.Console.Haskeline hiding (completeFilename) import Control.Concurrent +import Control.Exception (finally) import Control.Monad.IO.Class -- Providing a non-monadic API for haskeline
System/Console/Haskeline/InputT.hs view
@@ -11,11 +11,14 @@ import System.Console.Haskeline.Backend import System.Console.Haskeline.Term -import System.Directory(getHomeDirectory)-import System.FilePath+import Control.Exception (IOException)+import Control.Monad.Catch+import Control.Monad.Fail as Fail import Control.Monad.Fix-import System.IO import Data.IORef+import System.Directory(getXdgDirectory, XdgDirectory(XdgConfig), doesFileExist, getHomeDirectory)+import System.FilePath+import System.IO -- | Application-specific customizations to the user interface. data Settings m = Settings {complete :: CompletionFunc m, -- ^ Custom tab completion.@@ -46,7 +49,8 @@ (ReaderT (IORef KillRing) (ReaderT Prefs (ReaderT (Settings m) m)))) a}- deriving (Functor, Applicative, Monad, MonadIO, MonadException)+ deriving (Functor, Applicative, Monad, MonadIO,+ MonadThrow, MonadCatch, MonadMask) -- NOTE: we're explicitly *not* making InputT an instance of our -- internal MonadState/MonadReader classes. Otherwise haddock -- displays those instances to the user, and it makes it seem like@@ -55,9 +59,33 @@ instance MonadTrans InputT where lift = InputT . lift . lift . lift . lift . lift +instance ( Fail.MonadFail m ) => Fail.MonadFail (InputT m) where+ fail = lift . Fail.fail+ instance ( MonadFix m ) => MonadFix (InputT m) where mfix f = InputT (mfix (unInputT . f)) +-- | Run an action in the underlying monad, as per 'lift', passing it a runner+-- function which restores the current 'InputT' context. This can be used in+-- the event that we have some function that takes an action in the underlying+-- monad as an argument (such as 'lift', 'hoist', 'forkIO', etc) and we want+-- to compose it with actions in 'InputT'.+withRunInBase :: Monad m =>+ ((forall a . InputT m a -> m a) -> m b) -> InputT m b+withRunInBase inner = InputT $ do+ runTerm <- ask+ history <- ask+ killRing <- ask+ prefs <- ask+ settings <- ask+ lift $ lift $ lift $ lift $ lift $ inner $+ flip runReaderT settings .+ flip runReaderT prefs .+ flip runReaderT killRing .+ flip runReaderT history .+ flip runReaderT runTerm .+ unInputT+ -- | Get the current line input history. getHistory :: MonadIO m => InputT m History getHistory = InputT get@@ -82,14 +110,14 @@ history <- get lift $ lift $ evalStateT' (histLog history) $ runUndoT $ evalStateT' layout f -instance MonadException m => CommandMonad (InputCmdT m) where+instance (MonadIO m, MonadMask m) => CommandMonad (InputCmdT m) where runCompletion lcs = do settings <- ask lift $ lift $ lift $ lift $ lift $ lift $ complete settings lcs -- | Run a line-reading application. Uses 'defaultBehavior' to determine the -- interaction behavior.-runInputTWithPrefs :: MonadException m => Prefs -> Settings m -> InputT m a -> m a+runInputTWithPrefs :: (MonadIO m, MonadMask m) => Prefs -> Settings m -> InputT m a -> m a runInputTWithPrefs = runInputTBehaviorWithPrefs defaultBehavior -- | Run a line-reading application. This function should suffice for most applications.@@ -101,7 +129,7 @@ -- If it uses terminal-style interaction, 'Prefs' will be read from the user's @~/.haskeline@ file -- (if present). -- If it uses file-style interaction, 'Prefs' are not relevant and will not be read.-runInputT :: MonadException m => Settings m -> InputT m a -> m a+runInputT :: (MonadIO m, MonadMask m) => Settings m -> InputT m a -> m a runInputT = runInputTBehavior defaultBehavior -- | Returns 'True' if the current session uses terminal-style interaction. (See 'Behavior'.)@@ -125,7 +153,7 @@ -- | Create and use a RunTerm, ensuring that it will be closed even if -- an async exception occurs during the creation or use.-withBehavior :: MonadException m => Behavior -> (RunTerm -> m a) -> m a+withBehavior :: (MonadIO m, MonadMask m) => Behavior -> (RunTerm -> m a) -> m a withBehavior (Behavior run) f = bracket (liftIO run) (liftIO . closeTerm) f -- | Run a line-reading application according to the given behavior.@@ -133,21 +161,21 @@ -- If it uses terminal-style interaction, 'Prefs' will be read from the -- user's @~/.haskeline@ file (if present). -- If it uses file-style interaction, 'Prefs' are not relevant and will not be read.-runInputTBehavior :: MonadException m => Behavior -> Settings m -> InputT m a -> m a+runInputTBehavior :: (MonadIO m, MonadMask m) => Behavior -> Settings m -> InputT m a -> m a runInputTBehavior behavior settings f = withBehavior behavior $ \run -> do prefs <- if isTerminalStyle run- then liftIO readPrefsFromHome+ then liftIO readUserPrefs else return defaultPrefs execInputT prefs settings run f -- | Run a line-reading application.-runInputTBehaviorWithPrefs :: MonadException m+runInputTBehaviorWithPrefs :: (MonadIO m, MonadMask m) => Behavior -> Prefs -> Settings m -> InputT m a -> m a runInputTBehaviorWithPrefs behavior prefs settings f = withBehavior behavior $ flip (execInputT prefs settings) f -- | Helper function to feed the parameters into an InputT.-execInputT :: MonadException m => Prefs -> Settings m -> RunTerm+execInputT :: (MonadIO m, MonadMask m) => Prefs -> Settings m -> RunTerm -> InputT m a -> m a execInputT prefs settings run (InputT f) = runReaderT' settings $ runReaderT' prefs@@ -188,11 +216,78 @@ preferTerm :: Behavior preferTerm = Behavior terminalRunTerm +#ifndef MINGW+-- | Use terminal-style interaction on the given input and output handles,+-- taking the terminal type from the @TERM@ environment variable.+--+-- This behavior is for driving Haskeline against a terminal that is not the+-- process's controlling terminal — for example, a serial console, a PTY pair+-- you opened yourself, or a socket-backed TTY. The caller is responsible for+-- closing @input@ and @output@ after use. Not available on Windows.+--+-- See 'useTermHandlesWith' to override the terminal type.+useTermHandles :: Handle -> Handle -> Behavior+useTermHandles input output =+ Behavior $ useTermHandlesRunTerm Nothing input output --- | Read 'Prefs' from @~/.haskeline.@ If there is an error reading the file,+-- | Like 'useTermHandles', but with the terminal type given explicitly+-- (e.g. @\"xterm-256color\"@ or @\"vt100\"@) instead of read from the @TERM@+-- environment variable.+--+-- The terminal type is only consulted when haskeline is built with terminfo+-- support; in non-terminfo builds it is ignored and a dumb terminal is used.+--+-- ==== __Example: a Haskeline session over a WebSocket__+--+-- Bridge a WebSocket to the master end of a PTY pair and run Haskeline+-- against the slave end. Uses the @websockets@ and @unix@ packages.+-- Pair this with a browser-side terminal emulator such as+-- <https://xtermjs.org/ Xterm.js> for an in-browser shell.+--+-- > import qualified Network.WebSockets as WS+-- > import System.Posix.Terminal (openPseudoTerminal)+-- > import System.Posix.IO (dup, fdToHandle)+-- > import Control.Applicative ((<|>))+-- > import Control.Concurrent.Async (Concurrently(..), runConcurrently)+-- > import Control.Monad (forever)+-- > import qualified Data.ByteString as BS+-- > import System.IO (hSetBuffering, BufferMode(..))+-- > import System.Console.Haskeline+-- >+-- > websocketUI :: WS.Connection -> IO ()+-- > websocketUI conn = do+-- > (master, slave) <- openPseudoTerminal+-- > slaveDup <- dup slave+-- > masterH <- fdToHandle master+-- > slaveIn <- fdToHandle slave+-- > slaveOut <- fdToHandle slaveDup+-- > hSetBuffering masterH NoBuffering+-- > -- Whichever of the three actions finishes first cancels the others.+-- > runConcurrently+-- > $ Concurrently (forever $ WS.receiveData conn >>= BS.hPut masterH)+-- > <|> Concurrently (forever $ BS.hGetSome masterH 4096 >>= WS.sendBinaryData conn)+-- > <|> Concurrently (runInputTBehavior+-- > (useTermHandlesWith "vt100" slaveIn slaveOut)+-- > defaultSettings loop)+-- > where+-- > loop = do+-- > minput <- getInputLine "% "+-- > case minput of+-- > Nothing -> return ()+-- > Just "quit" -> return ()+-- > Just s -> outputStrLn ("got: " ++ s) >> loop+useTermHandlesWith :: String -> Handle -> Handle -> Behavior+useTermHandlesWith termtype input output =+ Behavior $ useTermHandlesRunTerm (Just termtype) input output+#endif++-- | Read 'Prefs' from @$XDG_CONFIG_HOME/haskeline/haskeline@ if present+-- ortherwise @~/.haskeline.@ If there is an error reading the file, -- the 'defaultPrefs' will be returned.-readPrefsFromHome :: IO Prefs-readPrefsFromHome = handle (\(_::IOException) -> return defaultPrefs) $ do- home <- getHomeDirectory- readPrefs (home </> ".haskeline")+readUserPrefs :: IO Prefs+readUserPrefs = handle (\(_::IOException) -> return defaultPrefs) $ do+ xdg <- getXdgDirectory XdgConfig ("haskeline/haskeline")+ exists <- doesFileExist xdg+ home <- getHomeDirectory+ readPrefs (if exists then xdg else (home </> ".haskeline"))
+ System/Console/Haskeline/Internal.hs view
@@ -0,0 +1,47 @@+-- | A module containing semi-public internals. The functions here are not+-- stable.+module System.Console.Haskeline.Internal+ ( module System.Console.Haskeline.Monads+ , module System.Console.Haskeline.Term+ , module System.Console.Haskeline.Key+ , module System.Console.Haskeline.LineState+ , Behavior (..)+ , debugTerminalKeys ) where++import System.Console.Haskeline (defaultSettings, outputStrLn)+import System.Console.Haskeline.Command+import System.Console.Haskeline.InputT+import System.Console.Haskeline.LineState+import System.Console.Haskeline.Monads+import System.Console.Haskeline.RunCommand+import System.Console.Haskeline.Term+import System.Console.Haskeline.Key++import Control.Monad ((>=>))++-- | This function may be used to debug Haskeline's input.+--+-- It loops indefinitely; every time a key is pressed, it will+-- print that key as it was recognized by Haskeline.+-- Pressing Ctrl-C will stop the loop.+--+-- Haskeline's behavior may be modified by editing your @~/.haskeline@+-- file. For details, see: <https://github.com/judah/haskeline/wiki/CustomKeyBindings>+--+debugTerminalKeys :: IO a+debugTerminalKeys = runInputT defaultSettings $ do+ outputStrLn+ "Press any keys to debug Haskeline's input, or ctrl-c to exit:"+ rterm <- InputT ask+ case termOps rterm of+ Right _ -> error "debugTerminalKeys: not run in terminal mode"+ Left tops -> runInputCmdT tops $ runCommandLoop tops prompt+ loop emptyIM+ where+ loop = KeyMap $ \k -> Just $ Consumed $+ (const $ do+ effect (LineChange $ const ([],[]))+ effect (PrintLines [show k])+ setState emptyIM)+ >=> keyCommand loop+ prompt = stringToGraphemes "> "
System/Console/Haskeline/Key.hs view
@@ -8,22 +8,30 @@ ctrlChar, metaKey, ctrlKey,- parseKey+ parseKey,+ setControlBits ) where +import Data.Bits import Data.Char-import Control.Monad import Data.Maybe-import Data.Bits+import Data.List (intercalate)+import Control.Monad data Key = Key Modifier BaseKey- deriving (Show,Eq,Ord)+ deriving (Eq,Ord) +instance Show Key where+ show (Key modifier base)+ | modifier == noModifier = show base+ | otherwise = show modifier ++ "-" ++ show base+ data Modifier = Modifier {hasControl, hasMeta, hasShift :: Bool} deriving (Eq,Ord) instance Show Modifier where- show m = show $ catMaybes [maybeUse hasControl "ctrl"+ show m = intercalate "-"+ $ catMaybes [maybeUse hasControl "ctrl" , maybeUse hasMeta "meta" , maybeUse hasShift "shift" ]@@ -33,14 +41,41 @@ noModifier :: Modifier noModifier = Modifier False False False +-- Note: a few of these aren't really keys (e.g., KillLine),+-- but they provide useful enough binding points to include. data BaseKey = KeyChar Char | FunKey Int | LeftKey | RightKey | DownKey | UpKey- -- TODO: is KillLine really a key? | KillLine | Home | End | PageDown | PageUp | Backspace | Delete- deriving (Show,Eq,Ord)+ | SearchReverse | SearchForward+ deriving (Eq, Ord) +instance Show BaseKey where+ show (KeyChar '\n') = "Return"+ show (KeyChar '\t') = "Tab"+ show (KeyChar '\ESC') = "Esc"+ show (KeyChar c)+ | isPrint c = [c]+ | isPrint unCtrld = "ctrl-" ++ [unCtrld]+ | otherwise = show c+ where+ unCtrld = toEnum (fromEnum c .|. ctrlBits)+ show (FunKey n) = 'f' : show n+ show LeftKey = "Left"+ show RightKey = "Right"+ show DownKey = "Down"+ show UpKey = "Up"+ show KillLine = "KillLine"+ show Home = "Home"+ show End = "End"+ show PageDown = "PageDown"+ show PageUp = "PageUp"+ show Backspace = "Backspace"+ show Delete = "Delete"+ show SearchReverse = "SearchReverse"+ show SearchForward = "SearchForward"+ simpleKey :: BaseKey -> Key simpleKey = Key noModifier @@ -58,8 +93,11 @@ setControlBits :: Char -> Char setControlBits '?' = toEnum 127-setControlBits c = toEnum $ fromEnum c .&. complement (bit 5 .|. bit 6)+setControlBits c = toEnum $ fromEnum c .&. complement ctrlBits +ctrlBits :: Int+ctrlBits = bit 5 .|. bit 6+ specialKeys :: [(String,BaseKey)] specialKeys = [("left",LeftKey) ,("right",RightKey)@@ -77,6 +115,8 @@ ,("tab",KeyChar '\t') ,("esc",KeyChar '\ESC') ,("escape",KeyChar '\ESC')+ ,("reversesearchhistory",SearchReverse)+ ,("forwardsearchhistory",SearchForward) ] parseModifiers :: [String] -> BaseKey -> Key
System/Console/Haskeline/LineState.hs view
@@ -74,7 +74,7 @@ -- can represent one grapheme; for example, an @a@ followed by the diacritic @\'\\768\'@ should -- be treated as one unit. data Grapheme = Grapheme {gBaseChar :: Char,- combiningChars :: [Char]}+ combiningChars :: [Char]} deriving Eq instance Show Grapheme where@@ -163,7 +163,7 @@ class Move s where goLeft, goRight, moveToStart, moveToEnd :: s -> s- + -- | The standard line state representation; considers the cursor to be located -- between two characters. The first list is reversed. data InsertMode = IMode [Grapheme] [Grapheme]@@ -181,7 +181,7 @@ restore = id instance Move InsertMode where- goLeft im@(IMode [] _) = im + goLeft im@(IMode [] _) = im goLeft (IMode (x:xs) ys) = IMode xs (x:ys) goRight im@(IMode _ []) = im@@ -194,7 +194,7 @@ emptyIM = IMode [] [] -- | Insert one character, which may be combining, to the left of the cursor.--- +-- insertChar :: Char -> InsertMode -> InsertMode insertChar c im@(IMode xs ys) | isCombiningChar c = case xs of@@ -203,7 +203,7 @@ z:zs -> IMode (addCombiner z c : zs) ys | otherwise = IMode (baseGrapheme c : xs) ys --- | Insert a sequence of characters to the left of the cursor. +-- | Insert a sequence of characters to the left of the cursor. insertString :: String -> InsertMode -> InsertMode insertString s (IMode xs ys) = IMode (reverse (stringToGraphemes s) ++ xs) ys @@ -212,12 +212,12 @@ deleteNext (IMode xs (_:ys)) = IMode xs ys deletePrev im@(IMode [] _) = im-deletePrev (IMode (_:xs) ys) = IMode xs ys +deletePrev (IMode (_:xs) ys) = IMode xs ys skipLeft, skipRight :: (Char -> Bool) -> InsertMode -> InsertMode-skipLeft f (IMode xs ys) = let (ws,zs) = span (f . baseChar) xs +skipLeft f (IMode xs ys) = let (ws,zs) = span (f . baseChar) xs in IMode zs (reverse ws ++ ys)-skipRight f (IMode xs ys) = let (ws,zs) = span (f . baseChar) ys +skipRight f (IMode xs ys) = let (ws,zs) = span (f . baseChar) ys in IMode (reverse ws ++ xs) zs transposeChars :: InsertMode -> InsertMode@@ -326,7 +326,7 @@ instance LineState s => LineState (ArgMode s) where beforeCursor _ am = let pre = map baseGrapheme $ "(arg: " ++ show (arg am) ++ ") "- in beforeCursor pre (argState am) + in beforeCursor pre (argState am) afterCursor = afterCursor . argState instance Result s => Result (ArgMode s) where@@ -342,15 +342,15 @@ addNum :: Int -> ArgMode s -> ArgMode s addNum n am | arg am >= 1000 = am -- shouldn't ever need more than 4 digits- | otherwise = am {arg = arg am * 10 + n} + | otherwise = am {arg = arg am * 10 + n} --- todo: negatives+-- TODO: negatives applyArg :: (s -> s) -> ArgMode s -> s applyArg f am = repeatN (arg am) f (argState am) repeatN :: Int -> (a -> a) -> a -> a repeatN n f | n <= 1 = f- | otherwise = f . repeatN (n-1) f+ | otherwise = f . repeatN (n-1) f applyCmdArg :: (InsertMode -> InsertMode) -> ArgMode CommandMode -> CommandMode applyCmdArg f am = withCommandMode (repeatN (arg am) f) (argState am)@@ -406,10 +406,9 @@ goRightUntil, goLeftUntil :: (InsertMode -> Bool) -> InsertMode -> InsertMode goRightUntil f = loop . goRight where- loop im@(IMode _ ys) | null ys || f im = im+ loop im@(IMode _ ys) | null ys || f im = im | otherwise = loop (goRight im) goLeftUntil f = loop . goLeft where- loop im@(IMode xs _) | null xs || f im = im- | otherwise = loop (goLeft im)-+ loop im@(IMode xs _) | null xs || f im = im+ | otherwise = loop (goLeft im)
− System/Console/Haskeline/MonadException.hs
@@ -1,180 +0,0 @@-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}-{- | This module redefines some of the functions in "Control.Exception" to-work for more general monads built on top of 'IO'.--}--module System.Console.Haskeline.MonadException(- -- * The MonadException class- MonadException(..),- -- * Generalizations of Control.Exception- catch,- handle,- catches,- Handler(..),- finally,- throwIO,- throwTo,- bracket,- -- * Helpers for defining \"wrapper\" functions- liftIOOp,- liftIOOp_,- -- * Internal implementation- RunIO(..),- -- * Extensible Exceptions- Exception,- SomeException(..),- E.IOException(),- )- where--import qualified Control.Exception as E-import Control.Exception (Exception,SomeException)-import Control.Monad(liftM, join)-import Control.Monad.IO.Class-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Reader-import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Error-import Control.Monad.Trans.List-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.RWS-import Control.Monad.Trans.Writer-import Control.Concurrent(ThreadId)---- This approach is based on that of the monad-control package.--- Since we want to use haskeline to bootstrap GHC, we reimplement--- a simplified version here. --- Additionally, we avoid TypeFamilies (which are used in the latest version of--- monad-control) so that we're still compatible with older versions of GHC.---- | A 'RunIO' function takes a monadic action @m@ as input,--- and outputs an IO action which performs the underlying impure part of @m@--- and returns the ''pure'' part of @m@.------ Note that @(RunIO return)@ is an incorrect implementation, since it does not--- separate the pure and impure parts of the monadic action. This module defines--- implementations for several common monad transformers.-newtype RunIO m = RunIO (forall b . m b -> IO (m b))--- Uses a newtype so we don't need RankNTypes.---- | An instance of 'MonadException' is generally made up of monad transformers--- layered on top of the IO monad. --- --- The 'controlIO' method enables us to \"lift\" a function that manages IO actions (such--- as 'bracket' or 'catch') into a function that wraps arbitrary monadic actions.-class MonadIO m => MonadException m where- controlIO :: (RunIO m -> IO (m a)) -> m a---- | Lift a IO operation--- --- > wrap :: (a -> IO b) -> IO b--- --- to a more general monadic operation--- --- > liftIOOp wrap :: MonadException m => (a -> m b) -> m b------ For example: ------ @--- 'liftIOOp' ('System.IO.withFile' f m) :: MonadException m => (Handle -> m r) -> m r--- 'liftIOOp' 'Foreign.Marshal.Alloc.alloca' :: (MonadException m, Storable a) => (Ptr a -> m b) -> m b--- 'liftIOOp' (`Foreign.ForeignPtr.withForeignPtr` fp) :: MonadException m => (Ptr a -> m b) -> m b--- @-liftIOOp :: MonadException m => ((a -> IO (m b)) -> IO (m c)) -> (a -> m b) -> m c-liftIOOp f g = controlIO $ \(RunIO run) -> f (run . g)---- | Lift an IO operation--- --- > wrap :: IO a -> IO a--- --- to a more general monadic operation--- --- > liftIOOp_ wrap :: MonadException m => m a -> m a-liftIOOp_ :: MonadException m => (IO (m a) -> IO (m a)) -> m a -> m a-liftIOOp_ f act = controlIO $ \(RunIO run) -> f (run act)---catch :: (MonadException m, E.Exception e) => m a -> (e -> m a) -> m a-catch act handler = controlIO $ \(RunIO run) -> E.catch- (run act)- (run . handler)--handle :: (MonadException m, Exception e) => (e -> m a) -> m a -> m a-handle = flip catch- -catches :: (MonadException m) => m a -> [Handler m a] -> m a-catches act handlers = controlIO $ \(RunIO run) ->- let catchesHandler e = foldr tryHandler (E.throw e) handlers- where tryHandler (Handler handler) res =- case E.fromException e of- Just e' -> run $ handler e'- Nothing -> res- in E.catch (run act) catchesHandler--data Handler m a = forall e . Exception e => Handler (e -> m a)---bracket :: MonadException m => m a -> (a -> m b) -> (a -> m c) -> m c-bracket before after thing - = controlIO $ \(RunIO run) -> E.bracket- (run before)- (\m -> run (m >>= after))- (\m -> run (m >>= thing))--finally :: MonadException m => m a -> m b -> m a-finally thing ender = controlIO $ \(RunIO run) -> E.finally (run thing) (run ender)--throwIO :: (MonadIO m, Exception e) => e -> m a-throwIO = liftIO . E.throwIO--throwTo :: (MonadIO m, Exception e) => ThreadId -> e -> m ()-throwTo tid = liftIO . E.throwTo tid--------------- Instances of MonadException.--- Since implementations of this class are non-obvious to a casual user,--- we provide instances for nearly everything in the transformers package.--instance MonadException IO where- controlIO f = join $ f (RunIO (liftM return))- -- Note: it's crucial that we use "liftM return" instead of "return" here.- -- For example, in "finally thing end", this ensures that "end" will always run, - -- regardless of whether an mzero occurred inside of "thing".--instance MonadException m => MonadException (ReaderT r m) where- controlIO f = ReaderT $ \r -> controlIO $ \(RunIO run) -> let- run' = RunIO (fmap (ReaderT . const) . run . flip runReaderT r)- in fmap (flip runReaderT r) $ f run'--instance MonadException m => MonadException (StateT s m) where- controlIO f = StateT $ \s -> controlIO $ \(RunIO run) -> let- run' = RunIO (fmap (StateT . const) . run . flip runStateT s)- in fmap (flip runStateT s) $ f run'--instance MonadException m => MonadException (MaybeT m) where- controlIO f = MaybeT $ controlIO $ \(RunIO run) -> let- run' = RunIO (fmap MaybeT . run . runMaybeT)- in fmap runMaybeT $ f run' --instance (MonadException m, Error e) => MonadException (ErrorT e m) where- controlIO f = ErrorT $ controlIO $ \(RunIO run) -> let- run' = RunIO (fmap ErrorT . run . runErrorT)- in fmap runErrorT $ f run'--instance MonadException m => MonadException (ListT m) where- controlIO f = ListT $ controlIO $ \(RunIO run) -> let- run' = RunIO (fmap ListT . run . runListT)- in fmap runListT $ f run'--instance (Monoid w, MonadException m) => MonadException (WriterT w m) where- controlIO f = WriterT $ controlIO $ \(RunIO run) -> let- run' = RunIO (fmap WriterT . run . runWriterT)- in fmap runWriterT $ f run'--instance (Monoid w, MonadException m) => MonadException (RWST r w s m) where- controlIO f = RWST $ \r s -> controlIO $ \(RunIO run) -> let- run' = RunIO (fmap (\act -> RWST (\_ _ -> act))- . run . (\m -> runRWST m r s))- in fmap (\m -> runRWST m r s) $ f run'--deriving instance MonadException m => MonadException (IdentityT m)
System/Console/Haskeline/Monads.hs view
@@ -1,5 +1,4 @@ module System.Console.Haskeline.Monads(- module System.Console.Haskeline.MonadException, MonadTrans(..), MonadIO(..), ReaderT,@@ -21,16 +20,17 @@ orElse ) where -import Control.Applicative (Applicative(..))-import Control.Monad (ap, liftM)+import Control.Monad (liftM)+import Control.Monad.Catch () import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Maybe (MaybeT(MaybeT),runMaybeT) import Control.Monad.Trans.Reader hiding (ask,asks) import qualified Control.Monad.Trans.Reader as Reader-import Data.IORef+import Control.Monad.Trans.State.Strict hiding (get, put, gets, modify)+import qualified Control.Monad.Trans.State.Strict as State -import System.Console.Haskeline.MonadException+import Data.IORef class Monad m => MonadReader r m where ask :: m r@@ -68,46 +68,9 @@ runReaderT' :: r -> ReaderT r m a -> m a runReaderT' = flip runReaderT -newtype StateT s m a = StateT { getStateTFunc - :: forall r . s -> m ((a -> s -> r) -> r)}--instance Monad m => Functor (StateT s m) where- fmap = liftM--instance Monad m => Applicative (StateT s m) where- pure x = StateT $ \s -> return $ \f -> f x s- (<*>) = ap--instance Monad m => Monad (StateT s m) where- return = pure- StateT f >>= g = StateT $ \s -> do- useX <- f s- useX $ \x s' -> getStateTFunc (g x) s'--instance MonadTrans (StateT s) where- lift m = StateT $ \s -> do- x <- m- return $ \f -> f x s--instance MonadIO m => MonadIO (StateT s m) where- liftIO = lift . liftIO--mapStateT :: (forall b . m b -> n b) -> StateT s m a -> StateT s n a-mapStateT f (StateT m) = StateT (\s -> f (m s))--runStateT :: Monad m => StateT s m a -> s -> m (a, s)-runStateT f s = do- useXS <- getStateTFunc f s- return $ useXS $ \x s' -> (x,s')--makeStateT :: Monad m => (s -> m (a,s)) -> StateT s m a-makeStateT f = StateT $ \s -> do- (x,s') <- f s- return $ \g -> g x s'- instance Monad m => MonadState s (StateT s m) where- get = StateT $ \s -> return $ \f -> f s s- put s = s `seq` StateT $ \_ -> return $ \f -> f () s+ get = State.get+ put x = State.put $! x instance {-# OVERLAPPABLE #-} (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (t m) where@@ -121,15 +84,7 @@ put s = ask >>= liftIO . flip writeIORef s evalStateT' :: Monad m => s -> StateT s m a -> m a-evalStateT' s f = liftM fst $ runStateT f s--instance MonadException m => MonadException (StateT s m) where- controlIO f = makeStateT $ \s -> controlIO $ \run ->- fmap (flip runStateT s) $ f $ stateRunIO s run- where- stateRunIO :: s -> RunIO m -> RunIO (StateT s m)- stateRunIO s (RunIO run) = RunIO (\m -> fmap (makeStateT . const)- $ run (runStateT m s))+evalStateT' = flip evalStateT orElse :: Monad m => MaybeT m a -> m a -> m a orElse (MaybeT f) g = f >>= maybe g return
System/Console/Haskeline/Prefs.hs view
@@ -9,10 +9,12 @@ lookupKeyBinding ) where +import Control.Monad.Catch (handle)+import Control.Exception (IOException) import Data.Char(isSpace,toLower) import Data.List(foldl') import qualified Data.Map as Map-import System.Console.Haskeline.MonadException(handle,IOException)+import Data.Word (Word) import System.Console.Haskeline.Key {- |@@ -47,7 +49,16 @@ -- presses @TAB@ again. customBindings :: Map.Map Key [Key], -- (termName, keysequence, key)- customKeySequences :: [(Maybe String, String,Key)]+ customKeySequences :: [(Maybe String, String,Key)],+ keyseqTimeoutMs :: !Word+ -- ^ After an @ESC@ byte is read, how long to wait+ -- (in milliseconds) for the rest of an escape+ -- sequence before treating the @ESC@ as a+ -- standalone keypress. Matters on slow links+ -- (e.g. low-bandwidth serial), where the bytes of+ -- a sequence such as @\\ESC[A@ may not arrive in+ -- a single read. Mirrors GNU Readline's+ -- @keyseq-timeout@. } deriving Show @@ -76,7 +87,8 @@ listCompletionsImmediately = True, historyDuplicates = AlwaysAdd, customBindings = Map.empty,- customKeySequences = []+ customKeySequences = [],+ keyseqTimeoutMs = 50 } mkSettor :: Read a => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs@@ -97,6 +109,7 @@ ,("completionpromptlimit", mkSettor $ \x p -> p {completionPromptLimit = x}) ,("listcompletionsimmediately", mkSettor $ \x p -> p {listCompletionsImmediately = x}) ,("historyduplicates", mkSettor $ \x p -> p {historyDuplicates = x})+ ,("keyseqtimeoutms", mkSettor $ \x p -> p {keyseqTimeoutMs = x}) ,("bind", addCustomBinding) ,("keyseq", addCustomKeySequence) ]
+ System/Console/Haskeline/ReaderT.hs view
@@ -0,0 +1,133 @@+-- | Provides an interface for 'ReaderT' rather than 'InputT'.+--+-- @since 0.8.4.0+module System.Console.Haskeline.ReaderT+ ( -- * ReaderT+ -- $reader+ toReaderT,+ fromReaderT,+ InputTEnv,+ mapInputTEnv,+ ) where++import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT))+import Data.IORef (IORef)+import System.Console.Haskeline.Command.KillRing (KillRing)+import System.Console.Haskeline.History (History)+import System.Console.Haskeline.InputT(+ InputT(InputT),+ Settings(+ Settings,+ autoAddHistory,+ complete,+ historyFile+ )+ )+import System.Console.Haskeline.Prefs (Prefs)+import System.Console.Haskeline.Term (RunTerm)+++-- $reader+--+-- These functions expose the 'InputT' type in terms of ordinary 'ReaderT'.+-- This allows for easier integration with applications that do not use a+-- concrete monad transformer stack, or do not want to commit to having+-- 'InputT' in the stack.++-- | The abstract environment used by 'InputT', for 'ReaderT'+-- usage.+--+-- @since 0.8.4.0+data InputTEnv m = MkInputTEnv+ { runTerm :: RunTerm,+ history :: IORef History,+ killRing :: IORef KillRing,+ prefs :: Prefs,+ settings :: Settings m+ }++-- | Maps the environment.+--+-- @since 0.8.4.0+mapInputTEnv :: (forall x. m x -> n x) -> InputTEnv m -> InputTEnv n+mapInputTEnv f (MkInputTEnv t h k p s) =+ MkInputTEnv+ { runTerm = t,+ history = h,+ killRing = k,+ prefs = p,+ settings = settings'+ }+ where+ settings' = Settings+ { complete = f . complete s,+ historyFile = historyFile s,+ autoAddHistory = autoAddHistory s+ }++-- | Maps an 'InputT' to a 'ReaderT'. Useful for lifting 'InputT' functions+-- into some other reader-like monad.+--+-- __Examples:__+--+-- @+-- import System.Console.Haskeline qualified as H+--+-- runApp :: ReaderT (InputTEnv IO) IO ()+-- runApp = do+-- input <- toReaderT (H.getInputLine "Enter your name: ")+-- ...+-- @+--+-- @+-- -- MTL-style polymorphism+-- class MonadHaskeline m where+-- getInputLine :: String -> m (Maybe String)+--+-- -- AppT is the core type over ReaderT.+-- instance MonadHaskeline (AppT m) where+-- getInputLine = lift . toReaderT . H.getInputLine+--+-- runApp :: (MonadHaskeline m) => m ()+-- runApp = do+-- input <- getInputLine "Enter your name: "+-- ...+-- @+--+-- @since 0.8.4.0+toReaderT :: InputT m a -> ReaderT (InputTEnv m) m a+toReaderT (InputT rdr) = ReaderT $ \st ->+ usingReaderT (settings st)+ . usingReaderT (prefs st)+ . usingReaderT (killRing st)+ . usingReaderT (history st)+ . usingReaderT (runTerm st)+ $ rdr++-- | Maps a 'ReaderT' to an 'InputT'. Allows defining an application in terms+-- of 'ReaderT'.+--+-- __Examples:__+--+-- @+-- import System.Console.Haskeline qualified as H+--+-- -- Could be generalized to MonadReader, effects libraries.+-- runApp :: ReaderT (InputTEnv IO) IO ()+--+-- main :: IO ()+-- main = H.runInputT H.defaultSettings $ fromReaderT runApp+-- @+--+-- @since 0.8.4.0+fromReaderT :: ReaderT (InputTEnv m) m a -> InputT m a+fromReaderT (ReaderT onEnv) = InputT $ ReaderT+ $ \runTerm' -> ReaderT+ $ \history' -> ReaderT+ $ \killRing' -> ReaderT+ $ \prefs' -> ReaderT+ $ \settings' ->+ onEnv (MkInputTEnv runTerm' history' killRing' prefs' settings')++usingReaderT :: env -> ReaderT env m a -> m a+usingReaderT = flip runReaderT
System/Console/Haskeline/RunCommand.hs view
@@ -7,16 +7,18 @@ import System.Console.Haskeline.Prefs import System.Console.Haskeline.Key +import Control.Exception (SomeException) import Control.Monad+import Control.Monad.Catch (handle, throwM) runCommandLoop :: (CommandMonad m, MonadState Layout m, LineState s)- => TermOps -> String -> KeyCommand m s a -> s -> m a+ => TermOps -> Prefix -> KeyCommand m s a -> s -> m a runCommandLoop tops@TermOps{evalTerm = e} prefix cmds initState = case e of -- NB: Need to separate this case out from the above pattern -- in order to build on ghc-6.12.3 EvalTerm eval liftE -> eval $ withGetEvent tops- $ runCommandLoop' liftE tops (stringToGraphemes prefix) initState + $ runCommandLoop' liftE tops prefix initState cmds runCommandLoop' :: forall m n s a . (Term n, CommandMonad n,@@ -30,10 +32,10 @@ where readMoreKeys :: LineChars -> KeyMap (CmdM m (a,[Key])) -> n a readMoreKeys s next = do- event <- handle (\(e::SomeException) -> moveToNextLine s- >> throwIO e) getEvent+ event <- handle (\(e::SomeException) -> moveToNextLine s >> throwM e)+ getEvent case event of- ErrorEvent e -> moveToNextLine s >> throwIO e+ ErrorEvent e -> moveToNextLine s >> throwM e WindowResize -> do drawReposition liftE tops s readMoreKeys s next
System/Console/Haskeline/Term.hs view
@@ -8,6 +8,14 @@ import Control.Concurrent import Control.Concurrent.STM+import Control.Exception (Exception, SomeException(..))+import Control.Monad.Catch+ ( MonadMask+ , bracket+ , handle+ , throwM+ , finally+ ) import Data.Word import Control.Exception (fromException, AsyncException(..)) import Data.Typeable@@ -17,7 +25,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BC -class (MonadReader Layout m, MonadException m) => Term m where+class (MonadReader Layout m, MonadIO m, MonadMask m) => Term m where reposition :: Layout -> LineChars -> m () moveToNextLine :: LineChars -> m () printLines :: [String] -> m ()@@ -34,7 +42,7 @@ -- | Write unicode characters to stdout. putStrOut :: String -> IO (), termOps :: Either TermOps FileOps,- wrapInterrupt :: forall a . IO a -> IO a,+ wrapInterrupt :: forall a m . (MonadIO m, MonadMask m) => m a -> m a, closeTerm :: IO () } @@ -68,7 +76,7 @@ -- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline -- are "wrapped" by wrapFileInput. data FileOps = FileOps {- withoutInputEcho :: forall m a . MonadException m => m a -> m a,+ withoutInputEcho :: forall m a . (MonadIO m, MonadMask m) => m a -> m a, -- ^ Perform an action without echoing input. wrapFileInput :: forall a . IO a -> IO a, getLocaleLine :: MaybeT IO String,@@ -100,12 +108,12 @@ -class (MonadReader Prefs m , MonadReader Layout m, MonadException m)+class (MonadReader Prefs m , MonadReader Layout m, MonadIO m, MonadMask m) => CommandMonad m where runCompletion :: (String,String) -> m (String,[Completion]) instance {-# OVERLAPPABLE #-} (MonadTrans t, CommandMonad m, MonadReader Prefs (t m),- MonadException (t m),+ MonadIO (t m), MonadMask (t m), MonadReader Layout (t m)) => CommandMonad (t m) where runCompletion = lift . runCompletion@@ -153,14 +161,14 @@ -- Utility functions for the various backends. -- | Utility function since we're not using the new IO library yet.-hWithBinaryMode :: MonadException m => Handle -> m a -> m a+hWithBinaryMode :: (MonadIO m, MonadMask m) => Handle -> m a -> m a hWithBinaryMode h = bracket (liftIO $ hGetEncoding h) (maybe (return ()) (liftIO . hSetEncoding h)) . const . (liftIO (hSetBinaryMode h True) >>) -- | Utility function for changing a property of a terminal for the duration of -- a computation.-bracketSet :: MonadException m => IO a -> (a -> IO ()) -> a -> m b -> m b+bracketSet :: (MonadMask m, MonadIO m) => IO a -> (a -> IO ()) -> a -> m b -> m b bracketSet getState set newState f = bracket (liftIO getState) (liftIO . set) (\_ -> liftIO (set newState) >> f)@@ -193,10 +201,10 @@ c <- hLookAhead h when (c == '\n') $ getChar >> return () -returnOnEOF :: MonadException m => a -> m a -> m a+returnOnEOF :: MonadMask m => a -> m a -> m a returnOnEOF x = handle $ \e -> if isEOFError e then return x- else throwIO e+ else throwM e -- | Utility function to correctly get a line of input as an undecoded ByteString. hGetLocaleLine :: Handle -> MaybeT IO ByteString
System/Console/Haskeline/Vi.hs view
@@ -1,4 +1,8 @@-module System.Console.Haskeline.Vi where+{-# LANGUAGE LambdaCase #-}+#if __GLASGOW_HASKELL__ < 802+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif+module System.Console.Haskeline.Vi (emptyViState, viKeyCommands) where import System.Console.Haskeline.Command import System.Console.Haskeline.Monads@@ -11,35 +15,40 @@ import System.Console.Haskeline.InputT import Data.Char-import Control.Monad(liftM)+import Control.Monad (liftM2, (>=>))+import Control.Monad.Catch (MonadMask) type EitherMode = Either CommandMode InsertMode type SavedCommand m = Command (ViT m) (ArgMode CommandMode) EitherMode -data ViState m = ViState { +data InlineSearch = F -- f | F+ | T -- t | T++data ViState m = ViState { lastCommand :: SavedCommand m,- lastSearch :: [Grapheme]+ lastSearch :: [Grapheme],+ lastInlineSearch :: Maybe (Char, InlineSearch, Direction) } emptyViState :: Monad m => ViState m emptyViState = ViState { lastCommand = return . Left . argState,- lastSearch = []+ lastSearch = [],+ lastInlineSearch = Nothing } type ViT m = StateT (ViState m) (InputCmdT m) -type InputCmd s t = forall m . MonadException m => Command (ViT m) s t-type InputKeyCmd s t = forall m . MonadException m => KeyCommand (ViT m) s t+type InputCmd s t = forall m . (MonadIO m, MonadMask m) => Command (ViT m) s t+type InputKeyCmd s t = forall m . (MonadIO m, MonadMask m) => KeyCommand (ViT m) s t viKeyCommands :: InputKeyCmd InsertMode (Maybe String)-viKeyCommands = choiceCmd [- simpleChar '\n' +> finish- , ctrlChar 'd' +> eofIfEmpty+viKeyCommands = choiceCmd+ [ simpleChar '\n' `useKey` finish+ , ctrlChar 'd' `useKey` eofIfEmpty , simpleInsertions >+> viCommands- , simpleChar '\ESC' +> change enterCommandMode- >|> viCommandActions+ , simpleChar '\ESC' `useKey` (change enterCommandMode >=> viCommandActions) ] viCommands :: InputCmd InsertMode (Maybe String)@@ -47,35 +56,38 @@ simpleInsertions :: InputKeyCmd InsertMode InsertMode simpleInsertions = choiceCmd- [ simpleKey LeftKey +> change goLeft - , simpleKey RightKey +> change goRight- , simpleKey Backspace +> change deletePrev - , simpleKey Delete +> change deleteNext - , simpleKey Home +> change moveToStart- , simpleKey End +> change moveToEnd- , insertChars- , ctrlChar 'l' +> clearScreenCmd- , simpleKey UpKey +> historyBack- , simpleKey DownKey +> historyForward- , searchHistory- , simpleKey KillLine +> killFromHelper (SimpleMove moveToStart)- , ctrlChar 'w' +> killFromHelper wordErase- , completionCmd (simpleChar '\t')- ]+ [ simpleKey LeftKey `useKey` change goLeft+ , simpleKey RightKey `useKey` change goRight+ , simpleKey Backspace `useKey` change deletePrev+ , simpleKey Delete `useKey` change deleteNext+ , simpleKey Home `useKey` change moveToStart+ , simpleKey End `useKey` change moveToEnd+ , insertChars+ , ctrlChar 'l' `useKey` clearScreenCmd+ , simpleKey UpKey `useKey` historyBack+ , simpleKey DownKey `useKey` historyForward+ , simpleKey SearchReverse `useKey` searchForPrefix Reverse+ , simpleKey SearchForward `useKey` searchForPrefix Forward+ , searchHistory+ , simpleKey KillLine `useKey` killFromHelper (SimpleMove moveToStart)+ , ctrlChar 'w' `useKey` killFromHelper wordErase+ , completionCmd (simpleChar '\t')+ ] insertChars :: InputKeyCmd InsertMode InsertMode insertChars = useChar $ loop [] where- loop ds d = change (insertChar d) >|> keyChoiceCmd [- useChar $ loop (d:ds)+ loop ds d = change (insertChar d)+ >=> keyChoiceCmd+ [ useChar $ loop (d:ds) , withoutConsuming (storeCharInsertion (reverse ds)) ]- storeCharInsertion s = storeLastCmd $ change (applyArg - $ withCommandMode $ insertString s)- >|> return . Left+ storeCharInsertion s = storeLastCmd+ $ change (applyArg $ withCommandMode $ insertString s)+ >=> return . Left -- If we receive a ^D and the line is empty, return Nothing--- otherwise, act like '\n' (mimicing how Readline behaves)+-- otherwise, act like '\n' (mimicking how Readline behaves) eofIfEmpty :: (Monad m, Save s, Result s) => Command m s (Maybe String) eofIfEmpty s | save s == emptyIM = return Nothing@@ -83,8 +95,8 @@ viCommandActions :: InputCmd CommandMode (Maybe String) viCommandActions = keyChoiceCmd [- simpleChar '\n' +> finish- , ctrlChar 'd' +> eofIfEmpty+ simpleChar '\n' `useKey` finish+ , ctrlChar 'd' `useKey` eofIfEmpty , simpleCmdActions >+> viCommandActions , exitingCommands >+> viCommands , repeatedCommands >+> chooseEitherMode@@ -95,39 +107,73 @@ chooseEitherMode (Right im) = viCommands im exitingCommands :: InputKeyCmd CommandMode InsertMode-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)- , simpleChar 'S' +> noArg >|> killAndStoreI killAll- , simpleChar 'C' +> noArg >|> killAndStoreI (SimpleMove moveToEnd)+exitingCommands = choiceCmd [+ simpleChar 'i' `useKey` change insertFromCommandMode+ , simpleChar 'I' `useKey` change (moveToStart . insertFromCommandMode)+ , simpleKey Home `useKey` change (moveToStart . insertFromCommandMode)+ , simpleChar 'a' `useKey` change appendFromCommandMode+ , simpleChar 'A' `useKey` change (moveToEnd . appendFromCommandMode)+ , simpleKey End `useKey` change (moveToStart . insertFromCommandMode)+ , simpleChar 's' `useKey` change (insertFromCommandMode . deleteChar)+ , simpleChar 'S' `useKey` (noArg >=> killAndStoreI killAll)+ , simpleChar 'C' `useKey` (noArg >=> killAndStoreI (SimpleMove moveToEnd)) ] simpleCmdActions :: InputKeyCmd CommandMode CommandMode-simpleCmdActions = choiceCmd [ - simpleChar '\ESC' +> change id -- helps break out of loops- , simpleChar 'r' +> replaceOnce - , simpleChar 'R' +> replaceLoop- , simpleChar 'D' +> noArg >|> killAndStoreCmd (SimpleMove moveToEnd)- , ctrlChar 'l' +> clearScreenCmd- , simpleChar 'u' +> commandUndo- , ctrlChar 'r' +> commandRedo+simpleCmdActions = choiceCmd [+ simpleChar '\ESC' `useKey` change id -- helps break out of loops+ , simpleChar 'r' `useKey` replaceOnce+ , simpleChar 'R' `useKey` replaceLoop+ , simpleChar 'D' `useKey` (noArg >=> killAndStoreC (SimpleMove moveToEnd))+ , ctrlChar 'l' `useKey` clearScreenCmd+ , simpleChar 'u' `useKey` commandUndo+ , ctrlChar 'r' `useKey` commandRedo -- vi-mode quirk: history is put at the start of the line.- , simpleChar 'j' +> historyForward >|> change moveToStart- , simpleChar 'k' +> historyBack >|> change moveToStart- , simpleKey DownKey +> historyForward >|> change moveToStart- , simpleKey UpKey +> historyBack >|> change moveToStart- , simpleChar '/' +> viEnterSearch '/' Reverse- , simpleChar '?' +> viEnterSearch '?' Forward- , simpleChar 'n' +> viSearchHist Reverse []- , simpleChar 'N' +> viSearchHist Forward []- , simpleKey KillLine +> noArg >|> killAndStoreCmd (SimpleMove moveToStart)+ , simpleChar 'j' `useKey` (historyForward >=> change moveToStart)+ , simpleChar 'k' `useKey` (historyBack >=> change moveToStart)+ , simpleKey DownKey `useKey` (historyForward >=> change moveToStart)+ , simpleKey UpKey `useKey` (historyBack >=> change moveToStart)+ , simpleChar '/' `useKey` viEnterSearch '/' Reverse+ , simpleChar '?' `useKey` viEnterSearch '?' Forward+ , simpleChar 'n' `useKey` viSearchHist Reverse []+ , simpleChar 'N' `useKey` viSearchHist Forward []+ , simpleKey KillLine `useKey` (noArg >=> killAndStoreC (SimpleMove moveToStart)) ] +inlineSearchActions :: InputKeyCmd (ArgMode CommandMode) CommandMode+inlineSearchActions = choiceCmd+ [ simpleChar 'f' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch F Forward c >>=) . viInlineSearch id)+ , simpleChar 'F' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch F Reverse c >>=) . viInlineSearch id)+ , simpleChar 't' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch T Forward c >>=) . viInlineSearch id)+ , simpleChar 'T' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch T Reverse c >>=) . viInlineSearch id)+ , simpleChar ';' `useKey` ((getLastInlineSearch >>=) . viInlineSearch id)+ , simpleChar ',' `useKey` ((getLastInlineSearch >>=) . viInlineSearch flipDir)+ ]++viInlineSearch :: Monad m => (Direction -> Direction)+ -> ArgMode CommandMode+ -> (Maybe (Char, InlineSearch, Direction))+ -> CmdM (ViT m) CommandMode+viInlineSearch flipdir = \s -> \case+ Nothing -> return $ argState s+ Just (g, fOrT, dir) -> setState $ (applyArg . withCommandMode . search fOrT (flipdir dir)) (== g) s+ where+ search :: InlineSearch -> Direction -> (Char -> Bool) -> InsertMode -> InsertMode+ search F Forward = goRightUntil . overChar+ search F Reverse = goLeftUntil . overChar+ search T Forward = goRightUntil . beforeChar+ search T Reverse = goLeftUntil . afterChar++getLastInlineSearch :: forall m. Monad m => CmdM (ViT m) (Maybe (Char, InlineSearch, Direction))+getLastInlineSearch = lastInlineSearch <$> (get :: CmdM (ViT m) (ViState m)) -- TODO: ideally this is a usage of `gets`++saveInlineSearch :: forall m. Monad m => InlineSearch -> Direction -> Char+ -> CmdM (ViT m) (Maybe (Char, InlineSearch, Direction))+saveInlineSearch fOrT dir char+ = do let ret = Just (char, fOrT, dir)+ modify $ \(vs :: ViState m) -> vs {lastInlineSearch = ret}+ return ret+ replaceOnce :: InputCmd CommandMode CommandMode replaceOnce = try $ changeFromChar replaceChar @@ -144,61 +190,63 @@ ] pureMovements :: InputKeyCmd (ArgMode CommandMode) CommandMode-pureMovements = choiceCmd $ charMovements ++ map mkSimpleCommand movements+pureMovements = choiceCmd $ map mkSimpleCommand movements where- charMovements = [ charMovement 'f' $ \c -> goRightUntil $ overChar (==c)- , charMovement 'F' $ \c -> goLeftUntil $ overChar (==c)- , charMovement 't' $ \c -> goRightUntil $ beforeChar (==c)- , charMovement 'T' $ \c -> goLeftUntil $ afterChar (==c)- ]- mkSimpleCommand (k,move) = k +> change (applyCmdArg move)- charMovement c move = simpleChar c +> keyChoiceCmd [- useChar (change . applyCmdArg . move)- , withoutConsuming (change argState)- ]+ mkSimpleCommand (k, move) = k `useKey` change (applyCmdArg move) -useMovementsForKill :: Command m s t -> (KillHelper -> Command m s t) -> KeyCommand m s t-useMovementsForKill alternate useHelper = choiceCmd $+useMovementsForKill :: (KillHelper -> Command m s t) -> KeyCommand m s t+useMovementsForKill useHelper = choiceCmd $ specialCases- ++ map (\(k,move) -> k +> useHelper (SimpleMove move)) movements+ ++ map (\(k,move) -> k `useKey` useHelper (SimpleMove move)) movements where- specialCases = [ simpleChar 'e' +> useHelper (SimpleMove goToWordDelEnd)- , simpleChar 'E' +> useHelper (SimpleMove goToBigWordDelEnd)- , simpleChar '%' +> useHelper (GenericKill deleteMatchingBrace)- -- Note 't' and 'f' behave differently than in pureMovements.- , charMovement 'f' $ \c -> goRightUntil $ afterChar (==c)- , charMovement 'F' $ \c -> goLeftUntil $ overChar (==c)- , charMovement 't' $ \c -> goRightUntil $ overChar (==c)- , charMovement 'T' $ \c -> goLeftUntil $ afterChar (==c)+ specialCases = [ simpleChar 'e' `useKey` useHelper (SimpleMove goToWordDelEnd)+ , simpleChar 'E' `useKey` useHelper (SimpleMove goToBigWordDelEnd)+ , simpleChar '%' `useKey` useHelper (GenericKill deleteMatchingBrace) ]- charMovement c move = simpleChar c +> keyChoiceCmd [- useChar (useHelper . SimpleMove . move)- , withoutConsuming alternate] +useInlineSearchForKill :: Monad m => Command (ViT m) s t -> (KillHelper -> Command (ViT m) s t) -> KeyMap (Command (ViT m) s t)+useInlineSearchForKill alternate killCmd = choiceCmd+ [ simpleChar 'f' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch F Forward c >>=) . getSearchAndKill)+ , simpleChar 'F' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch F Reverse c >>=) . getSearchAndKill)+ , simpleChar 't' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch T Forward c >>=) . getSearchAndKill)+ , simpleChar 'T' `useKey` keyCommand (useChar $ \c -> (saveInlineSearch T Reverse c >>=) . getSearchAndKill)+ , simpleChar ';' `useKey` ((getLastInlineSearch >>=) . getSearchAndKill)+ , simpleChar ',' `useKey` ((reverseDir <$> getLastInlineSearch >>=) . getSearchAndKill)+ ]+ where+ getSearchAndKill = \s+ -> \case (Just (g, fOrT, forOrRev)) -> killCmd (SimpleMove $ moveForKill fOrT forOrRev $ (== g)) s+ Nothing -> alternate s + moveForKill F Forward = goRightUntil . afterChar+ moveForKill F Reverse = goLeftUntil . overChar+ moveForKill T Forward = goRightUntil . overChar+ moveForKill T Reverse = goLeftUntil . afterChar+ repeatableCommands :: InputKeyCmd (ArgMode CommandMode) EitherMode repeatableCommands = choiceCmd [ repeatableCmdToIMode , repeatableCmdMode >+> return . Left- , simpleChar '.' +> saveForUndo >|> runLastCommand+ , simpleChar '.' `useKey` (saveForUndo >=> runLastCommand) ] where- runLastCommand s = liftM lastCommand get >>= ($ s)+ runLastCommand s = fmap lastCommand get >>= ($ s) repeatableCmdMode :: InputKeyCmd (ArgMode CommandMode) CommandMode repeatableCmdMode = choiceCmd- [ simpleChar 'x' +> repeatableChange deleteChar- , simpleChar 'X' +> repeatableChange (withCommandMode deletePrev)- , simpleChar '~' +> repeatableChange (goRight . flipCase)- , simpleChar 'p' +> storedCmdAction (pasteCommand pasteGraphemesAfter)- , simpleChar 'P' +> storedCmdAction (pasteCommand pasteGraphemesBefore)- , simpleChar 'd' +> deletionCmd- , simpleChar 'y' +> yankCommand- , ctrlChar 'w' +> killAndStoreCmd wordErase+ [ simpleChar 'x' `useKey` repeatableChange deleteChar+ , simpleChar 'X' `useKey` repeatableChange (withCommandMode deletePrev)+ , simpleChar '~' `useKey` repeatableChange (goRight . flipCase)+ , simpleChar 'p' `useKey` storedCmdAction (pasteCommand pasteGraphemesAfter)+ , simpleChar 'P' `useKey` storedCmdAction (pasteCommand pasteGraphemesBefore)+ , simpleChar 'd' `useKey` deletionCmd+ , simpleChar 'y' `useKey` yankCommand+ , ctrlChar 'w' `useKey` killAndStoreC wordErase+ , inlineSearchActions , pureMovements ] where- repeatableChange f = storedCmdAction (saveForUndo >|> change (applyArg f))+ repeatableChange f = storedCmdAction (saveForUndo >=> change (applyArg f)) flipCase :: CommandMode -> CommandMode flipCase CEmpty = CEmpty@@ -208,38 +256,39 @@ | otherwise = toLower c repeatableCmdToIMode :: InputKeyCmd (ArgMode CommandMode) EitherMode-repeatableCmdToIMode = simpleChar 'c' +> deletionToInsertCmd+repeatableCmdToIMode = simpleChar 'c' `useKey` deletionToInsertCmd deletionCmd :: InputCmd (ArgMode CommandMode) CommandMode deletionCmd = keyChoiceCmd- [ reinputArg >+> deletionCmd- , simpleChar 'd' +> killAndStoreCmd killAll- , useMovementsForKill (change argState) killAndStoreCmd- , withoutConsuming (change argState)- ]+ [ reinputArg >+> deletionCmd+ , simpleChar 'd' `useKey` killAndStoreC killAll+ , useMovementsForKill killAndStoreC+ , useInlineSearchForKill (change argState) killAndStoreC+ , withoutConsuming (change argState)+ ] deletionToInsertCmd :: InputCmd (ArgMode CommandMode) EitherMode deletionToInsertCmd = keyChoiceCmd [ reinputArg >+> deletionToInsertCmd- , simpleChar 'c' +> killAndStoreIE killAll+ , simpleChar 'c' `useKey` killAndStoreE killAll -- vim, for whatever reason, treats cw same as ce and cW same as cE. -- readline does this too, so we should also.- , simpleChar 'w' +> killAndStoreIE (SimpleMove goToWordDelEnd)- , simpleChar 'W' +> killAndStoreIE (SimpleMove goToBigWordDelEnd)- , useMovementsForKill (liftM Left . change argState) killAndStoreIE+ , simpleChar 'w' `useKey` killAndStoreE (SimpleMove goToWordDelEnd)+ , simpleChar 'W' `useKey` killAndStoreE (SimpleMove goToBigWordDelEnd)+ , useMovementsForKill killAndStoreE+ , useInlineSearchForKill (fmap Left . change argState) killAndStoreE , withoutConsuming (return . Left . argState) ] yankCommand :: InputCmd (ArgMode CommandMode) CommandMode yankCommand = keyChoiceCmd- [ reinputArg >+> yankCommand- , simpleChar 'y' +> copyAndStore killAll- , useMovementsForKill (change argState) copyAndStore- , withoutConsuming (change argState)- ]- where- copyAndStore = storedCmdAction . copyFromArgHelper+ [ reinputArg >+> yankCommand+ , simpleChar 'y' `useKey` copyAndStore killAll+ , useMovementsForKill copyAndStore+ , useInlineSearchForKill (change argState) copyAndStore+ , withoutConsuming (change argState)+ ] reinputArg :: LineState s => InputKeyCmd (ArgMode s) (ArgMode s) reinputArg = foreachDigit restartArg ['1'..'9'] >+> loop@@ -256,7 +305,7 @@ goToBigWordDelEnd = goRightUntil $ atStart (not . isBigWordChar) -movements :: [(Key,InsertMode -> InsertMode)]+movements :: [(Key, InsertMode -> InsertMode)] movements = [ (simpleChar 'h', goLeft) , (simpleChar 'l', goRight) , (simpleChar ' ', goRight)@@ -282,26 +331,26 @@ , (simpleChar 'E', goRightUntil (atEnd isBigWordChar)) ] -{- +{- From IEEE 1003.1: A "bigword" consists of: a maximal sequence of non-blanks preceded and followed by blanks A "word" consists of either: - a maximal sequence of wordChars, delimited at both ends by non-wordchars - a maximal sequence of non-blank non-wordchars, delimited at both ends by either blanks or a wordchar.--} +-} isBigWordChar, isWordChar, isOtherChar :: Char -> Bool isBigWordChar = not . isSpace isWordChar = isAlphaNum .||. (=='_') isOtherChar = not . (isSpace .||. isWordChar) (.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool-(f .||. g) x = f x || g x+(.||.) = liftM2 (||) -foreachDigit :: (Monad m, LineState t) => (Int -> s -> t) -> [Char] +foreachDigit :: (Monad m, LineState t) => (Int -> s -> t) -> [Char] -> KeyCommand m s t foreachDigit f ds = choiceCmd $ map digitCmd ds- where digitCmd d = simpleChar d +> change (f (toDigit d))+ where digitCmd d = simpleChar d `useKey` change (f (toDigit d)) toDigit d = fromEnum d - fromEnum '0' @@ -342,7 +391,7 @@ | baseChar x == d = n-1 | otherwise = n -matchingRightBrace, matchingLeftBrace :: Char -> Maybe Char +matchingRightBrace, matchingLeftBrace :: Char -> Maybe Char matchingRightBrace = flip lookup braceList matchingLeftBrace = flip lookup (map (\(c,d) -> (d,c)) braceList) @@ -352,13 +401,13 @@ --------------- -- Replace mode replaceLoop :: InputCmd CommandMode CommandMode-replaceLoop = saveForUndo >|> change insertFromCommandMode >|> loop- >|> change enterCommandModeRight+replaceLoop = saveForUndo >=> change insertFromCommandMode >=> loop+ >=> change enterCommandModeRight where loop = try (oneReplaceCmd >+> loop) oneReplaceCmd = choiceCmd [- simpleKey LeftKey +> change goLeft- , simpleKey RightKey +> change goRight+ simpleKey LeftKey `useKey` change goLeft+ , simpleKey RightKey `useKey` change goRight , changeFromChar replaceCharIM ] @@ -372,25 +421,28 @@ return s storedAction :: Monad m => SavedCommand m -> SavedCommand m-storedAction act = storeLastCmd act >|> act+storedAction act = storeLastCmd act >=> act storedCmdAction :: Monad m => Command (ViT m) (ArgMode CommandMode) CommandMode- -> Command (ViT m) (ArgMode CommandMode) CommandMode-storedCmdAction act = storeLastCmd (liftM Left . act) >|> act+ -> Command (ViT m) (ArgMode CommandMode) CommandMode+storedCmdAction act = storeLastCmd (fmap Left . act) >=> act storedIAction :: Monad m => Command (ViT m) (ArgMode CommandMode) InsertMode- -> Command (ViT m) (ArgMode CommandMode) InsertMode-storedIAction act = storeLastCmd (liftM Right . act) >|> act+ -> Command (ViT m) (ArgMode CommandMode) InsertMode+storedIAction act = storeLastCmd (fmap Right . act) >=> act -killAndStoreCmd :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode-killAndStoreCmd = storedCmdAction . killFromArgHelper+killAndStoreC :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode+killAndStoreC = storedCmdAction . killFromArgHelper killAndStoreI :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) InsertMode killAndStoreI = storedIAction . killFromArgHelper -killAndStoreIE :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) EitherMode-killAndStoreIE helper = storedAction (killFromArgHelper helper >|> return . Right)+killAndStoreE :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) EitherMode+killAndStoreE helper = storedAction (killFromArgHelper helper >=> return . Right) +copyAndStore :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode+copyAndStore = storedCmdAction . copyFromArgHelper+ noArg :: Monad m => Command m s (ArgMode s) noArg = return . startArg 1 @@ -415,19 +467,18 @@ viEnterSearch c dir s = setState (SearchEntry emptyIM c) >>= loopEntry where modifySE f se = se {entryState = f (entryState se)}- loopEntry = keyChoiceCmd [- editEntry >+> loopEntry- , simpleChar '\n' +> \se -> - viSearchHist dir (searchText se) s+ loopEntry = keyChoiceCmd+ [ editEntry >+> loopEntry+ , simpleChar '\n' `useKey` \se -> viSearchHist dir (searchText se) s , withoutConsuming (change (const s)) ]- editEntry = choiceCmd [- useChar (change . modifySE . insertChar)- , simpleKey LeftKey +> change (modifySE goLeft)- , simpleKey RightKey +> change (modifySE goRight)- , simpleKey Backspace +> change (modifySE deletePrev)- , simpleKey Delete +> change (modifySE deleteNext)- ] + editEntry = choiceCmd+ [ useChar (change . modifySE . insertChar)+ , simpleKey LeftKey `useKey` change (modifySE goLeft)+ , simpleKey RightKey `useKey` change (modifySE goRight)+ , simpleKey Backspace `useKey` change (modifySE deletePrev)+ , simpleKey Delete `useKey` change (modifySE deleteNext)+ ] viSearchHist :: forall m . Monad m => Direction -> [Grapheme] -> Command (ViT m) CommandMode CommandMode@@ -445,3 +496,8 @@ Right sm -> do put vstate {lastSearch = toSearch'} setState (restore (foundHistory sm))++reverseDir :: Maybe (a, b, Direction) -> Maybe (a, b, Direction)+reverseDir = (third3 flipDir <$>)+ where+ third3 f (a, b, c) = (a, b, f c)
cbits/h_wcwidth.c view
@@ -67,7 +67,7 @@ }; /* auxiliary function for binary search in interval table */-static int haskeline_bisearch(wchar_t ucs, const struct interval *table, int max) {+static int haskeline_bisearch(int ucs, const struct interval *table, int max) { int min = 0; int mid; @@ -119,7 +119,7 @@ * in ISO 10646. */ -int haskeline_mk_wcwidth(wchar_t ucs)+int haskeline_mk_wcwidth(int ucs) { /* sorted list of non-overlapping intervals of non-spacing characters */ /* generated by "uniset +cat=Me +cat=Mn +cat=Cf -00AD +1160-11FF +200B c" */
examples/Test.hs view
@@ -1,41 +1,138 @@+{-# LANGUAGE CPP #-} module Main where import System.Console.Haskeline-import System.Environment-import Control.Exception (AsyncException(..))+import Options.Applicative+import Data.Monoid ((<>))+#ifndef MINGW+import System.IO (openFile, hClose, IOMode(..))+#endif {-- Testing the line-input functions and their interaction with ctrl-c signals. Usage:-./Test (line input)-./Test chars (character input)-./Test password (no masking characters)-./Test password \*-./Test initial (use initial text in the prompt)+ ./Test (line input, default Behavior)+ ./Test chars (character input)+ ./Test password (no masking)+ ./Test password \* (masking with '*')+ ./Test initial (initial text in the prompt)++ ./Test --mode useTermHandles (POSIX only)+ ./Test --mode useTermHandlesWith --term-type vt100+ (POSIX only)++The --mode flag selects the haskeline Behavior; positional INPUT_ARG+selects which prompt function to use, and works with any --mode. --} +data Mode+ = UseTerm -- ^ defaultBehavior+ | UseTermHandles -- ^ useTermHandles on /dev/tty+ | UseTermHandlesWith String -- ^ useTermHandlesWith TERM on /dev/tty++data InputMode+ = LineInput+ | CharInput+ | PasswordInput (Maybe Char)+ | InitialInput++data Opts = Opts { optMode :: Mode, optInput :: InputMode }+ mySettings :: Settings IO mySettings = defaultSettings {historyFile = Just "myhist"} main :: IO () main = do- args <- getArgs- let inputFunc = case args of- ["chars"] -> fmap (fmap (\c -> [c])) . getInputChar- ["password"] -> getPassword Nothing- ["password", [c]] -> getPassword (Just c)- ["initial"] -> flip getInputLineWithInitial ("left ", "right")- _ -> getInputLine- runInputT mySettings $ withInterrupt $ loop inputFunc 0- where- loop inputFunc n = do- minput <- handle (\Interrupt -> return (Just "Caught interrupted"))- $ inputFunc (show n ++ ":")- case minput of- Nothing -> return ()- Just "quit" -> return ()- Just "q" -> return ()- Just s -> do- outputStrLn ("line " ++ show n ++ ":" ++ s)- loop inputFunc (n+1)+ Opts {optMode = m, optInput = im} <- execParser optsInfo+ case m of+ UseTerm ->+ runInputT mySettings (runAction im)+#ifndef MINGW+ UseTermHandles ->+ runWithHandles Nothing im+ UseTermHandlesWith t ->+ runWithHandles (Just t) im+#else+ _ -> error "useTermHandles[With] is not available on Windows"+#endif++runAction :: InputMode -> InputT IO ()+runAction im = withInterrupt $ loop (inputFunc im) 0++inputFunc :: InputMode -> String -> InputT IO (Maybe String)+inputFunc LineInput = getInputLine+inputFunc CharInput = fmap (fmap (\c -> [c])) . getInputChar+inputFunc (PasswordInput mc) = getPassword mc+inputFunc InitialInput = flip getInputLineWithInitial ("left ", "right")++loop :: (String -> InputT IO (Maybe String)) -> Int -> InputT IO ()+loop f n = do+ minput <- handleInterrupt (return (Just "Caught interrupted"))+ $ f (show n ++ ":")+ case minput of+ Nothing -> return ()+ Just "quit" -> return ()+ Just "q" -> return ()+ Just s -> do+ outputStrLn ("line " ++ show n ++ ":" ++ s)+ loop f (n+1)++#ifndef MINGW+-- Drive Haskeline against /dev/tty (the controlling terminal) via the+-- useTermHandles[With] Behaviors. This still happens to be the controlling+-- tty in our test setup, but it goes through the new code path.+runWithHandles :: Maybe String -> InputMode -> IO ()+runWithHandles mTerm im = do+ input <- openFile "/dev/tty" ReadMode+ output <- openFile "/dev/tty" WriteMode+ let beh = case mTerm of+ Nothing -> useTermHandles input output+ Just t -> useTermHandlesWith t input output+ runInputTBehavior beh mySettings (runAction im)+ hClose input+ hClose output+#endif++----------------------------------------------------------------+-- Command-line parsing++optsInfo :: ParserInfo Opts+optsInfo = info (optsP <**> helper)+ (fullDesc <> progDesc "Haskeline test program")++optsP :: Parser Opts+optsP = Opts <$> modeP <*> inputModeP++modeP :: Parser Mode+modeP = mkMode+ <$> strOption+ ( long "mode"+ <> value "useTerm"+ <> showDefault+ <> metavar "MODE"+ <> help "useTerm | useTermHandles | useTermHandlesWith" )+ <*> optional+ (strOption+ ( long "term-type"+ <> metavar "TERM"+ <> help "term type for --mode useTermHandlesWith" ))+ where+ mkMode "useTerm" _ = UseTerm+ mkMode "useTermHandles" _ = UseTermHandles+ mkMode "useTermHandlesWith" (Just t) = UseTermHandlesWith t+ mkMode "useTermHandlesWith" Nothing =+ error "--mode useTermHandlesWith requires --term-type"+ mkMode other _ =+ error ("unknown --mode: " ++ other)++inputModeP :: Parser InputMode+inputModeP = mkInput <$> many (argument str (metavar "INPUT_ARG"))+ where+ mkInput [] = LineInput+ mkInput ["chars"] = CharInput+ mkInput ["password"] = PasswordInput Nothing+ mkInput ["password", [c]] = PasswordInput (Just c)+ mkInput ["initial"] = InitialInput+ mkInput xs =+ error ("unrecognized positional args: " ++ show xs)
haskeline.cabal view
@@ -1,12 +1,12 @@ Name: haskeline Cabal-Version: >=1.10-Version: 0.7.5.0+Version: 0.8.5.0 Category: User Interfaces License: BSD3 License-File: LICENSE Copyright: (c) Judah Jacobson Author: Judah Jacobson-Maintainer: Judah Jacobson <judah.jacobson@gmail.com>+Maintainer: Troels Henriksen <athas@sigkill.dk> Synopsis: A command-line interface for user input, written in Haskell. Description: Haskeline provides a user interface for line input in command-line@@ -15,15 +15,31 @@ Haskell programs. . Haskeline runs both on POSIX-compatible systems and on Windows.-Homepage: https://github.com/judah/haskeline-Bug-Reports: https://github.com/judah/haskeline/issues+Homepage: https://github.com/haskell/haskeline+Bug-Reports: https://github.com/haskell/haskeline/issues Stability: Stable Build-Type: Simple-extra-source-files: examples/Test.hs Changelog includes/*.h +tested-with:+ GHC == 9.12.1+ GHC == 9.10.1+ GHC == 9.8.2+ GHC == 9.6.5+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2++extra-source-files: examples/Test.hs Changelog+ source-repository head type: git- location: git://github.com/judah/haskeline.git+ location: https://github.com/judah/haskeline.git -- There are three main advantages to the terminfo backend over the portable, -- "dumb" alternative. First, it enables more efficient control sequences@@ -38,14 +54,24 @@ Default: True Manual: True +-- Help the GHC build by making it possible to disable the extra binary.+-- TODO: Make GHC handle packages with both a library and an executable.+flag examples+ Description: Enable executable components used for tests.+ Default: True+ Manual: True+ Library- -- We require ghc>=7.4.1 (base>=4.5) to use the base library encodings, even- -- though it was implemented in earlier releases, due to GHC bug #5436 which- -- wasn't fixed until 7.4.1- Build-depends: base >=4.9 && < 4.13, containers>=0.4 && < 0.7,- directory>=1.1 && < 1.4, bytestring>=0.9 && < 0.11,- filepath >= 1.2 && < 1.5, transformers >= 0.4 && < 0.6,- process >= 1.0 && < 1.7, stm >= 2.4 && < 2.6+ Build-depends:+ base >= 4.9 && < 4.23+ , containers >= 0.4 && < 0.9+ , directory >= 1.1 && < 1.4+ , bytestring >= 0.9 && < 0.13+ , filepath >= 1.2 && < 1.6+ , transformers >= 0.2 && < 0.7+ , process >= 1.0 && < 1.7+ , stm >= 2.4 && < 2.6+ , exceptions == 0.10.* Default-Language: Haskell98 Default-Extensions: ForeignFunctionInterface, Rank2Types, FlexibleInstances,@@ -60,9 +86,10 @@ Exposed-Modules: System.Console.Haskeline System.Console.Haskeline.Completion- System.Console.Haskeline.MonadException System.Console.Haskeline.History System.Console.Haskeline.IO+ System.Console.Haskeline.Internal+ System.Console.Haskeline.ReaderT Other-Modules: System.Console.Haskeline.Backend System.Console.Haskeline.Backend.WCWidth@@ -85,15 +112,15 @@ include-dirs: includes c-sources: cbits/h_wcwidth.c - if os(windows) {- Build-depends: Win32>=2.0+ if os(windows)+ Build-depends: Win32 >= 2.1 && < 2.10 || >= 2.12 Other-modules: System.Console.Haskeline.Backend.Win32 System.Console.Haskeline.Backend.Win32.Echo c-sources: cbits/win_console.c includes: win_console.h, windows_cconv.h install-includes: win_console.h cpp-options: -DMINGW- } else {+ else Build-depends: unix>=2.0 && < 2.9 Other-modules: System.Console.Haskeline.Backend.Posix@@ -107,5 +134,42 @@ if os(solaris) { cpp-options: -DUSE_TERMIOS_H }++ ghc-options: -Wall -Wcompat++test-suite haskeline-tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ Default-Language: Haskell98++ if os(windows) {+ buildable: False }- ghc-options: -Wall+ if !flag(examples) {+ buildable: False+ }+ Main-Is: Unit.hs+ Build-depends:+ -- shared dependencies with library+ base >= 4.9 && < 4.23+ , containers >= 0.4 && < 0.9+ , bytestring >= 0.9 && < 0.13+ , directory+ , process >= 1.0 && < 1.7+ -- dependencies for test-suite+ , HUnit+ , text+ , unix >= 2.0 && < 2.9++ Other-Modules: RunTTY, Pty+ build-tool-depends: haskeline:haskeline-examples-Test++-- The following program is used by unit tests in `tests` executable+Executable haskeline-examples-Test+ if !flag(examples) {+ buildable: False+ }+ Build-depends: base, containers, haskeline, optparse-applicative+ Default-Language: Haskell2010+ hs-source-dirs: examples+ Main-Is: Test.hs
− includes/h_iconv.h
@@ -1,9 +0,0 @@-#include <iconv.h>--iconv_t haskeline_iconv_open(const char *tocode, const char *fromcode);--void haskeline_iconv_close(iconv_t cd);--size_t haskeline_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft,- char **outbuf, size_t *outbytesleft);-
− includes/windows_cconv.h
@@ -1,12 +0,0 @@-#ifndef WINDOWS_CCONV_H-#define WINDOWS_CCONV_H--#if defined(i386_HOST_ARCH)-# define WINDOWS_CCONV stdcall-#elif defined(x86_64_HOST_ARCH)-# define WINDOWS_CCONV ccall-#else-# error Unknown mingw32 arch-#endif--#endif
+ tests/Pty.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- This module is a quick-and-dirty way to run an executable+-- within a pseudoterminal and obtain its output.+-- +-- It is not intended for general use. In particular:+-- - It expects the output to be available quickly (<0.2s)+-- after each chunk of input.+-- - It expects each output chunk be no more than 4096 bytes.+module Pty (runCommandInPty) where++import System.Posix.Types+import System.Posix.Terminal+import System.Posix.Process+import System.Posix.Signals+import qualified Data.ByteString as B+import System.Posix.IO.ByteString+import Foreign.Marshal.Alloc+import Foreign.C.Error+import Foreign.C.Types+import Foreign.Ptr+import Control.Concurrent++-- Run the given command in a pseudoterminal, and return its output chunks.+-- Read the initial output, then feed the given input to it+-- one block at a time.+-- After each input, pause for 0.2s and then read as much output as possible.+runCommandInPty :: String -> [String] -> Maybe [(String,String)]+ -> [B.ByteString] -> IO [B.ByteString]+runCommandInPty prog args env inputs = do+ (fd,pid) <- forkCommandInPty prog args env+ -- Block until the initial output from the program.+ -- After that, only use non-blocking reads. Otherwise,+ -- we would hang the program in cases where the program has no output+ -- in between inputs.+ firstOutput <- getOutput fd+ setFdOption fd NonBlockingRead True+ outputs <- mapM (inputOutput fd) inputs+ signalProcess killProcess pid+ _status <- getProcessStatus True False pid+ closeFd fd+ return (firstOutput : outputs)++inputOutput :: Fd -> B.ByteString -> IO B.ByteString+inputOutput fd input = do+ putInput fd input+ getOutput fd++putInput :: Fd -> B.ByteString -> IO ()+putInput fd input =+ B.useAsCStringLen input $ \(cstr,len) -> do+ written <- fdWriteBuf fd (castPtr cstr) (fromIntegral len)+ if written == 0+ then threadDelay 1000 >> putInput fd input+ else return ()++getOutput :: Fd -> IO B.ByteString+getOutput fd = do+ threadDelay 20000+ allocaBytes (fromIntegral numBytes) $ \buf -> do+ num <- fdReadNonBlocking fd buf numBytes+ B.packCStringLen (castPtr buf, fromIntegral num)+ where+ numBytes = 4096+++-- Unlike fdReadBuf, don't throw an error if nothing's immediately available.+-- Instead, just return empty output.+fdReadNonBlocking :: Fd -> Ptr CChar -> CSize -> IO CSsize+fdReadNonBlocking fd buf n = do+ num_read <- c_read fd buf n+ if num_read >= 0+ then return num_read+ else do+ e <- getErrno+ if e == eAGAIN+ then return 0+ else throwErrno "fdReadNonBlocking"++foreign import ccall "read" c_read :: Fd -> Ptr CChar -> CSize -> IO CSsize+++-- returns the master Fd, and the pid for the subprocess.+forkCommandInPty :: String -> [String] -> Maybe [(String,String)]+ -> IO (Fd,ProcessID)+forkCommandInPty prog args env = do+ (master,slave) <- openPseudoTerminal+ pid <- forkProcess $ do+ closeFd master+ loginTTY slave+ executeFile prog False args env+ return (master,pid)+++loginTTY :: Fd -> IO ()+loginTTY = throwErrnoIfMinus1_ "loginTTY" . login_tty++foreign import ccall login_tty :: Fd -> IO CInt+
+ tests/RunTTY.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE RecordWildCards #-}+-- This module provides an interface for testing the output+-- of programs that expect to be run in a terminal.+module RunTTY (Invocation(..),+ runInvocation,+ assertInvocation,+ testI,+ setLang,+ setTerm,+ setLatin1,+ setUTF8+ ) where++import Control.Concurrent+import Data.ByteString as B+import System.IO+import System.Process+import Test.HUnit+import qualified Data.ByteString.Char8 as BC++import Pty+++data Invocation = Invocation {+ prog :: FilePath+ -- | Mode-selection flags passed before any positional args+ -- (e.g. @[\"--mode\", \"useTermHandles\"]@).+ , progModeArgs :: [String]+ -- | Positional input-mode args (e.g. @[\"chars\"]@).+ , progInputArgs :: [String]+ , runInTTY :: Bool+ , environment :: [(String,String)]+ }++progArgs :: Invocation -> [String]+progArgs Invocation{..} = progModeArgs ++ progInputArgs++setEnv :: String -> String -> Invocation -> Invocation+setEnv var val Invocation {..} = Invocation{+ environment = (var,val) : Prelude.filter ((/=var).fst) environment+ ,..+ }++setLang :: String -> Invocation -> Invocation+setLang = setEnv "LANG"+setTerm :: String -> Invocation -> Invocation+setTerm = setEnv "TERM"+++setUTF8 :: Invocation -> Invocation+setUTF8 = setLang "C.UTF-8"+setLatin1 :: Invocation -> Invocation+setLatin1 = setLang "C.ISO8859-1"+++runInvocation :: Invocation+ -> [B.ByteString] -- Input chunks. (We pause after each chunk to+ -- simulate real user input and prevent Haskeline+ -- from coalescing the changes.)+ -> IO [B.ByteString]+runInvocation inv@Invocation {..} inputs+ | runInTTY = runCommandInPty prog (progArgs inv) (Just environment) inputs+ | otherwise = do+ (Just inH, Just outH, Nothing, ph)+ <- createProcess (proc prog (progArgs inv))+ { env = Just environment+ , std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = Inherit+ }+ hSetBuffering inH NoBuffering+ firstOutput <- getOutput outH+ outputs <- mapM (inputOutput inH outH) inputs+ hClose inH+ lastOutput <- getOutput outH -- output triggered by EOF, if any+ terminateProcess ph+ _ <- waitForProcess ph+ return $ firstOutput : outputs+ ++ if B.null lastOutput then [] else [lastOutput]++inputOutput :: Handle -> Handle -> B.ByteString -> IO B.ByteString+inputOutput inH outH input = do+ B.hPut inH input+ getOutput outH+++getOutput :: Handle -> IO B.ByteString+getOutput h = do+ threadDelay 20000+ B.hGetNonBlocking h 4096+++assertInvocation :: Invocation -> [B.ByteString] -> [B.ByteString]+ -> Assertion+assertInvocation i input expectedOutput = do+ actualOutput <- runInvocation i input+ assertSameList expectedOutput $ fmap fixOutput actualOutput++-- Remove CRLFs from output, since tty translates all LFs into CRLF.+-- (TODO: I'd like to just unset ONLCR in the slave tty, but+-- System.Posix.Terminal doesn't support that flag.)+fixOutput :: B.ByteString -> B.ByteString+fixOutput = BC.pack . loop . BC.unpack+ where+ loop ('\r':'\n':rest) = '\n' : loop rest+ loop (c:cs) = c : loop cs+ loop [] = []++assertSameList :: (Show a, Eq a) => [a] -> [a] -> Assertion+assertSameList [] [] = return ()+assertSameList (x:xs) (y:ys)+ | x == y = assertSameList xs ys+assertSameList xs ys = xs @=? ys -- cause error to be thrown++testI :: Invocation -> [B.ByteString] -> [B.ByteString] -> Test+testI i inp outp = test $ assertInvocation i inp outp
+ tests/Unit.hs view
@@ -0,0 +1,374 @@+{-# LANGUAGE OverloadedStrings #-}+-- Requirements:+-- - Empty ~/.haskeline (or set to defaults)+-- - On Mac OS X, the "dumb term" test may fail.+-- In particular, the line "* UTF-8" which makes locale_charset()+-- always return UTF-8; otherwise we can't test latin-1.+-- - NB: Window size isn't provided by screen so it's picked up from+-- terminfo or defaults (either way: 80x24), rather than the user's+-- terminal.+module Main where++import Control.Monad (when)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Data.Word+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import Data.Monoid ((<>))+import System.Directory (createDirectoryIfMissing)+import System.Exit (exitFailure)+import System.Process (readProcess)+import Test.HUnit++import RunTTY++legacyEncoding :: Bool+legacyEncoding = False++-- Generally we want the legacy and new backends to perform the same.+-- The only two differences I'm aware of are:+-- 1. base decodes invalid bytes as '\65533', but legacy decodes them as '?'+-- 2. if there's an incomplete sequence and no more input immediately+-- available (but not eof), then base will pause to wait for more input,+-- whereas legacy will immediately stop.+whenLegacy :: BC.ByteString -> BC.ByteString+whenLegacy s = if legacyEncoding then s else B.empty++-- These files are used to test tab completion.+makeTestFiles :: IO ()+makeTestFiles = do+ createDirectoryIfMissing True "tests/dummy-μασ"+ writeFile "tests/dummy-μασ/bar" ""+ writeFile "tests/dummy-μασ/ςερτ" ""++main :: IO ()+main = do+ -- forkProcess needs an absolute path to the binary.+ p <- head . lines <$> readProcess "which" ["haskeline-examples-Test"] ""+ let i = setTerm "xterm"+ Invocation {+ prog = p,+ progModeArgs = [],+ progInputArgs = [],+ runInTTY = True,+ environment = []+ }+ makeTestFiles+ result <- runTestTT $ test+ [ interactionTests UseTerm i+ , interactionTests UseTermHandles i+ , interactionTests (UseTermHandlesWith "xterm") i+ -- dumbTests sets TERM=dumb in env to drive Haskeline into the dumb+ -- backend. That works for UseTerm and UseTermHandles (both consult+ -- env), but not for UseTermHandlesWith — it ignores env and uses its+ -- explicit term type — so we skip it for that mode.+ , dumbTests UseTerm i+ , dumbTests UseTermHandles i+ , fileStyleTests i+ ]+ when (errors result > 0 || failures result > 0) exitFailure++-- | Which haskeline Behavior the test program should run under.+data Mode+ = UseTerm -- ^ runInputT (defaultBehavior)+ | UseTermHandles -- ^ useTermHandles on /dev/tty+ | UseTermHandlesWith String -- ^ useTermHandlesWith TERM on /dev/tty++modeName :: Mode -> String+modeName UseTerm = "useTerm"+modeName UseTermHandles = "useTermHandles"+modeName (UseTermHandlesWith t) = "useTermHandlesWith=" ++ t++setMode :: Mode -> Invocation -> Invocation+setMode m i = i { progModeArgs = modeArgs m }+ where+ modeArgs UseTerm = []+ modeArgs UseTermHandles = ["--mode", "useTermHandles"]+ modeArgs (UseTermHandlesWith t) = ["--mode", "useTermHandlesWith", "--term-type", t]++interactionTests :: Mode -> Invocation -> Test+interactionTests m i = ("interaction (" ++ modeName m ++ ")") ~: test+ [ unicodeEncoding ii+ , unicodeMovement ii+ , tabCompletion ii+ , incorrectInput ii+ , historyTests ii+ , inputChar $ setCharInput ii+ ]+ where+ ii = setMode m i++unicodeEncoding :: Invocation -> Test+unicodeEncoding i = "Unicode encoding (valid)" ~:+ [ utf8Test i [utf8 "xαβγy"]+ [prompt 0, utf8 "xαβγy"]+ , utf8Test i [utf8 "a\n", "quit\n"]+ [ prompt 0+ , utf8 "a" <> end+ <> output 0 (utf8 "a") <> prompt 1+ , utf8 "quit" <> end+ ]+ , utf8Test i [utf8 "xαβyψ안기q영\n", "quit\n"]+ [ prompt 0+ , utf8 "xαβyψ안기q영" <> end+ <> output 0 (utf8 "xαβyψ안기q영") <> prompt 1+ , utf8 "quit" <> end+ ]+ -- test buffering: 32 bytes is in middle of a char encoding,+ -- also test long paste+ , "multipleLines" ~: utf8Test i [l1 <> "\n" <> l1]+ [ prompt 0+ , l1 <> end <> output 0 l1 <> prompt 1 <> l1]+ ]+ where+ l1 = utf8 $ T.replicate 30 "안" -- three bytes, width 60++unicodeMovement :: Invocation -> Test+unicodeMovement i = "Unicode movement" ~:+ [ "separate" ~: utf8Test i [utf8 "α", utf8 "\ESC[Dx"]+ [prompt 0, utf8 "α", utf8 "\bxα\b"]+ , "coalesced" ~: utf8Test i [utf8 "α\ESC[Dx"]+ [prompt 0, utf8 "xα\b"]+ , "lineWrap" ~: utf8Test i+ [ utf8 longWideChar+ , raw [1]+ , raw [5]+ ]+ [prompt 0, utf8 lwc1 <> wrap <> utf8 lwc2 <> wrap <> utf8 lwc3+ , cr <> "\ESC[2A\ESC[2C"+ , cr <> nl <> nl <> "\ESC[22C"+ ]++ ]+ where+ longWideChar = T.concat $ replicate 30 $ "안기영"+ (lwc1,lwcs1) = T.splitAt ((80-2)`div`2) longWideChar+ (lwc2,lwcs2) = T.splitAt (80`div`2) lwcs1+ (lwc3,_lwcs3) = T.splitAt (80`div`2) lwcs2+ -- lwc3 has length 90 - (80-2)/2 - 80/2 = 11,+ -- so the last line as wide width 2*11=22.++tabCompletion :: Invocation -> Test+tabCompletion i = "tab completion" ~:+ [ utf8Test i [ utf8 "tests/dummy-μ\t\t" ]+ [ prompt 0, utf8 "tests/dummy-μασ/"+ <> nl <> utf8 "bar ςερτ" <> nl+ <> prompt' 0 <> utf8 "tests/dummy-μασ/"+ ]+ ]++incorrectInput :: Invocation -> Test+incorrectInput i = "incorrect input" ~:+ [ utf8Test i [ utf8 "x" <> raw [206] ] -- needs one more byte+ -- non-legacy encoder ignores the "206" since it's still waiting+ -- for more input.+ [ prompt 0, utf8 "x" <> whenLegacy err ]+ , utf8Test i [ raw [206] <> utf8 "x" ]+ -- 'x' is not valid after '\206', so both the legacy and+ -- non-legacy encoders should handle the "x" correctly.+ [ prompt 0, err <> utf8 "x"]+ , utf8Test i [ raw [236,149] <> utf8 "x" ] -- needs one more byte+ [prompt 0, err <> err <> utf8 "x"]+ ]++historyTests :: Invocation -> Test+historyTests i = "history encoding" ~:+ [ utf8TestValidHist i [ "\ESC[A" ]+ [prompt 0, utf8 "abcα" ]+ , utf8TestInvalidHist i [ "\ESC[A" ]+ -- NB: this is decoded by either utf8-string or base;+ -- either way they produce \65533 instead of '?'.+ [prompt 0, utf8 "abcα\65533x\65533x\65533" ]+ -- In latin-1: read errors as utf-8 '\65533', display as '?'+ , latin1TestInvalidHist i [ "\ESC[A" ]+ [prompt 0, utf8 "abc??x?x?" ]+ ]++invalidHist :: BC.ByteString+invalidHist = utf8 "abcα"+ `B.append` raw [149] -- invalid start of UTF-8 sequence+ `B.append` utf8 "x"+ `B.append` raw [206] -- incomplete start+ `B.append` utf8 "x"+ -- incomplete at end of file+ `B.append` raw [206]++validHist :: BC.ByteString+validHist = utf8 "abcα"++inputChar :: Invocation -> Test+inputChar i = "getInputChar" ~:+ [ utf8Test i [utf8 "xαβ"]+ [ prompt 0, utf8 "x" <> end <> output 0 (utf8 "x")+ <> prompt 1 <> utf8 "α" <> end <> output 1 (utf8 "α")+ <> prompt 2 <> utf8 "β" <> end <> output 2 (utf8 "β")+ <> prompt 3+ ]+ , "bad encoding (separate)" ~:+ utf8Test i [utf8 "α", raw [149], utf8 "x", raw [206]]+ [ prompt 0, utf8 "α" <> end <> output 0 (utf8 "α") <> prompt 1+ , err <> end <> output 1 err <> prompt 2+ , utf8 "x" <> end <> output 2 (utf8 "x") <> prompt 3+ , whenLegacy (err <> end <> output 3 err <> prompt 4)+ ]+ , "bad encoding (together)" ~:+ utf8Test i [utf8 "α" <> raw [149] <> utf8 "x" <> raw [206]]+ [ prompt 0, utf8 "α" <> end <> output 0 (utf8 "α")+ <> prompt 1 <> err <> end <> output 1 err+ <> prompt 2 <> utf8 "x" <> end <> output 2 (utf8 "x")+ <> prompt 3 <> whenLegacy (err <> end <> output 3 err <> prompt 4)+ ]+ , utf8Test i [raw [206]] -- incomplete+ [ prompt 0, whenLegacy (utf8 "?" <> end <> output 0 (utf8 "?"))+ <> whenLegacy (prompt 1)+ ]+ ]++setCharInput :: Invocation -> Invocation+setCharInput i = i { progInputArgs = ["chars"] }+++fileStyleTests :: Invocation -> Test+fileStyleTests i = "file style" ~:+ [ "line input" ~: utf8Test iFile+ [utf8 "xαβyψ안기q영\nquit\n"]+ [ prompt' 0, output 0 (utf8 "xαβyψ안기q영") <> prompt' 1]+ , "char input" ~: utf8Test iFileChar+ [utf8 "xαβt"]+ [ prompt' 0+ , output 0 (utf8 "x")+ <> prompt' 1 <> output 1 (utf8 "α")+ <> prompt' 2 <> output 2 (utf8 "β")+ <> prompt' 3 <> output 3 (utf8 "t")+ <> prompt' 4]+ , "invalid line input" ~: utf8Test iFile+ -- NOTE: the 206 is an incomplete byte sequence,+ -- but we MUST not pause since we're at EOF, not just+ -- end of term.+ --+ -- Also recall GHC bug #5436 which caused a crash+ -- if the last byte started an incomplete sequence.+ [ utf8 "a" <> raw [149] <> utf8 "x" <> raw [206] ]+ [ prompt' 0+ , B.empty+ -- It only prompts after the EOF.+ , output 0 (utf8 "a" <> err <> utf8 "x" <> err) <> prompt' 1+ ]+ , "invalid char input (following a newline)" ~: utf8Test iFileChar+ [ utf8 "a\n" <> raw [149] <> utf8 "x\n" <> raw [206] ]+ $ [ prompt' 0+ , output 0 (utf8 "a")+ <> prompt' 1 <> output 1 err+ <> prompt' 2 <> output 2 (utf8 "x")+ <> prompt' 3+ <> whenLegacy (output 3 err <> prompt' 4)+ ] ++ if legacyEncoding then [] else [ output 3 err <> prompt' 4 ]+ , "invalid char file input (no preceding newline)" ~: utf8Test iFileChar+ [ utf8 "a" <> raw [149] <> utf8 "x" <> raw [206] ]+ -- make sure it tries to read a newline+ -- and instead gets the incomplete 206.+ -- This should *not* cause it to crash or block.+ $ [ prompt' 0+ , output 0 (utf8 "a")+ <> prompt' 1 <> output 1 err+ <> prompt' 2 <> output 2 (utf8 "x")+ <> prompt' 3+ <> whenLegacy (output 3 err <> prompt' 4)+ ] ++ if legacyEncoding then [] else [ output 3 err <> prompt' 4 ]+ ]+ -- also single char and buffer break and other stuff+ where+ iFile = i { runInTTY = False }+ iFileChar = setCharInput iFile++-- Test that the dumb terminal backend does encoding correctly.+-- If all the above tests work for the terminfo backend,+-- then we just need to make sure the dumb term plugs into everything+-- correctly, i.e., encodes the input/output and doesn't double-encode.+dumbTests :: Mode -> Invocation -> Test+dumbTests m i = ("dumb term (" ++ modeName m ++ ")") ~:+ [ "line input" ~: utf8Test ii+ [ utf8 "xαβγy" ]+ [ prompt' 0, utf8 "xαβγy" ]+ , "line input wide movement" ~: utf8Test ii+ [ utf8 wideChar, raw [1], raw [5] ]+ [ prompt' 0, utf8 wideChar+ , utf8 (T.replicate 60 "\b")+ , utf8 wideChar+ ]+ , "line char input" ~: utf8Test (setCharInput ii)+ [utf8 "xαβ"]+ [ prompt' 0, utf8 "x" <> dumbnl <> output 0 (utf8 "x")+ <> prompt' 1 <> utf8 "α" <> dumbnl <> output 1 (utf8 "α")+ <> prompt' 2 <> utf8 "β" <> dumbnl <> output 2 (utf8 "β")+ <> prompt' 3+ ]+ ]+ where+ ii = setMode m $ setTerm "dumb" i+ dumbnl = raw [13,10]+ wideChar = T.concat $ replicate 10 $ "안기영"++-------------+-- Building blocks for expected input/output++smkx,rmkx :: B.ByteString+smkx = utf8 "\ESC[?1h\ESC="+rmkx = utf8 "\ESC[?1l\ESC>"++prompt, prompt' :: Int -> B.ByteString+prompt k = smkx <> prompt' k++prompt' k = utf8 (T.pack (show k ++ ":"))++end :: B.ByteString+end = nl <> rmkx++cr :: B.ByteString+cr = raw [13]++nl :: B.ByteString+nl = raw [27, 69]++output :: Int -> B.ByteString -> B.ByteString+output k s = utf8 (T.pack $ "line " ++ show k ++ ":")+ <> s <> raw [10]++wrap :: B.ByteString+wrap = utf8 " \b"++utf8 :: T.Text -> B.ByteString+utf8 = E.encodeUtf8++raw :: [Word8] -> B.ByteString+raw = B.pack++err :: B.ByteString+err = if legacyEncoding+ then utf8 "?"+ else utf8 "\65533"++----------------------++utf8Test ::+ Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test+utf8Test = testI . setUTF8++utf8TestInvalidHist ::+ Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test+utf8TestInvalidHist i input output' = test $ do+ B.writeFile "myhist" $ invalidHist+ assertInvocation (setUTF8 i) input output'++utf8TestValidHist ::+ Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test+utf8TestValidHist i input output' = test $ do+ B.writeFile "myhist" validHist+ assertInvocation (setUTF8 i) input output'++latin1TestInvalidHist ::+ Invocation -> [BC.ByteString] -> [BC.ByteString] -> Test+latin1TestInvalidHist i input output' = test $ do+ B.writeFile "myhist" $ invalidHist+ assertInvocation (setLatin1 i) input output'