haskeline 0.8.3.0 → 0.8.5.0
raw patch · 26 files changed
Files
- Changelog +33/−0
- System/Console/Haskeline.hs +14/−4
- System/Console/Haskeline/Backend.hs +17/−5
- System/Console/Haskeline/Backend/Posix.hsc +113/−28
- System/Console/Haskeline/Backend/Terminfo.hs +3/−3
- System/Console/Haskeline/Backend/Win32.hsc +1/−3
- System/Console/Haskeline/Command.hs +20/−21
- System/Console/Haskeline/Command/Completion.hs +3/−2
- System/Console/Haskeline/Command/History.hs +10/−6
- System/Console/Haskeline/Command/KillRing.hs +12/−12
- System/Console/Haskeline/Command/Undo.hs +2/−3
- System/Console/Haskeline/Completion.hs +2/−2
- System/Console/Haskeline/Emacs.hs +2/−1
- System/Console/Haskeline/InputT.hs +64/−0
- System/Console/Haskeline/Internal.hs +12/−2
- System/Console/Haskeline/Key.hs +2/−1
- System/Console/Haskeline/LineState.hs +15/−16
- System/Console/Haskeline/Monads.hs +1/−1
- System/Console/Haskeline/Prefs.hs +14/−2
- System/Console/Haskeline/ReaderT.hs +133/−0
- System/Console/Haskeline/Vi.hs +195/−145
- examples/Test.hs +123/−26
- haskeline.cabal +10/−7
- includes/windows_cconv.h +0/−12
- tests/RunTTY.hs +13/−6
- tests/Unit.hs +64/−22
Changelog view
@@ -1,3 +1,35 @@+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.@@ -30,6 +62,7 @@ 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`.
System/Console/Haskeline.hs view
@@ -39,6 +39,10 @@ defaultBehavior, useFileHandle, useFile,+#ifndef MINGW+ useTermHandles,+ useTermHandlesWith,+#endif preferTerm, -- * User interaction functions -- ** Reading user input@@ -60,6 +64,7 @@ setComplete, -- ** User preferences Prefs(),+ keyseqTimeoutMs, readPrefs, defaultPrefs, runInputTWithPrefs,@@ -91,6 +96,7 @@ import System.Console.Haskeline.Key import System.Console.Haskeline.RunCommand +import Control.Monad ((>=>)) import Control.Monad.Catch (MonadMask, handle) import Data.Char (isSpace, isPrint) import Data.Maybe (isJust)@@ -144,6 +150,10 @@ 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 :: (MonadIO m, MonadMask m) => String -- ^ The input prompt@@ -228,7 +238,7 @@ 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] @@ -282,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
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/Posix.hsc view
@@ -11,6 +11,7 @@ mapLines, stdinTTYHandles, ttyHandles,+ explicitTTYHandles, posixRunTerm, fileRunTerm ) where@@ -201,16 +202,55 @@ = 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 :: (MonadIO m, MonadMask m, MonadReader Prefs m)@@ -218,8 +258,9 @@ -> (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 :: (MonadIO m, MonadMask m) => TChan Event -> m a -> m a withWindowHandler eventChan = withHandler windowChange $@@ -237,27 +278,62 @@ 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@@ -286,6 +362,15 @@ 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
System/Console/Haskeline/Backend/Terminfo.hs view
@@ -125,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
System/Console/Haskeline/Backend/Win32.hsc view
@@ -381,9 +381,7 @@ crlf = "\r\n" instance (MonadMask m, MonadIO 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)+ 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.
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
@@ -15,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@@ -35,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@@ -59,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
System/Console/Haskeline/Command/History.hs view
@@ -17,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)]@@ -45,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') @@ -73,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],@@ -84,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@@ -105,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
@@ -18,7 +18,7 @@ import System.FilePath-import Data.List(isPrefixOf)+import Data.List(isPrefixOf, sort) import Control.Monad(forM) import System.Console.Haskeline.Directory@@ -186,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
@@ -13,6 +13,7 @@ import System.Console.Haskeline.LineState import System.Console.Haskeline.InputT +import Control.Monad ((>=>)) import Control.Monad.Catch (MonadMask) import Data.Char @@ -32,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]
System/Console/Haskeline/InputT.hs view
@@ -216,6 +216,70 @@ 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++-- | 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,
System/Console/Haskeline/Internal.hs view
@@ -1,5 +1,12 @@+-- | A module containing semi-public internals. The functions here are not+-- stable. module System.Console.Haskeline.Internal- ( debugTerminalKeys ) where+ ( 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@@ -8,7 +15,10 @@ 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@@ -33,5 +43,5 @@ effect (LineChange $ const ([],[])) effect (PrintLines [show k]) setState emptyIM)- >|> keyCommand loop+ >=> keyCommand loop prompt = stringToGraphemes "> "
System/Console/Haskeline/Key.hs view
@@ -8,7 +8,8 @@ ctrlChar, metaKey, ctrlKey,- parseKey+ parseKey,+ setControlBits ) where import Data.Bits
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/Monads.hs view
@@ -84,7 +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+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
@@ -14,6 +14,7 @@ import Data.Char(isSpace,toLower) import Data.List(foldl') import qualified Data.Map as Map+import Data.Word (Word) import System.Console.Haskeline.Key {- |@@ -48,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 @@ -77,7 +87,8 @@ listCompletionsImmediately = True, historyDuplicates = AlwaysAdd, customBindings = Map.empty,- customKeySequences = []+ customKeySequences = [],+ keyseqTimeoutMs = 50 } mkSettor :: Read a => (a -> Prefs -> Prefs) -> String -> Prefs -> Prefs@@ -98,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/Vi.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE LambdaCase #-} #if __GLASGOW_HASKELL__ < 802 {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif-module System.Console.Haskeline.Vi where+module System.Console.Haskeline.Vi (emptyViState, viKeyCommands) where import System.Console.Haskeline.Command import System.Console.Haskeline.Monads@@ -14,22 +15,27 @@ 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)@@ -38,12 +44,11 @@ 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)@@ -51,34 +56,35 @@ 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- , simpleKey SearchReverse +> searchForPrefix Reverse- , simpleKey SearchForward +> searchForPrefix Forward- , 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' (mimicking how Readline behaves)@@ -89,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@@ -101,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 @@ -150,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@@ -214,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@@ -262,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)@@ -288,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' @@ -348,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) @@ -358,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 ] @@ -378,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 @@ -421,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@@ -451,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)
examples/Test.hs view
@@ -1,41 +1,138 @@+{-# LANGUAGE CPP #-} module Main where import System.Console.Haskeline-import System.Environment+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 :: (String -> InputT IO (Maybe String)) -> Int -> InputT IO ()- loop inputFunc n = do- minput <- handleInterrupt (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,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.10-Version: 0.8.3.0+Version: 0.8.5.0 Category: User Interfaces License: BSD3 License-File: LICENSE@@ -21,6 +21,7 @@ Build-Type: Simple tested-with:+ GHC == 9.12.1 GHC == 9.10.1 GHC == 9.8.2 GHC == 9.6.5@@ -34,7 +35,7 @@ GHC == 8.2.2 GHC == 8.0.2 -extra-source-files: examples/Test.hs Changelog includes/*.h+extra-source-files: examples/Test.hs Changelog source-repository head type: git@@ -62,8 +63,8 @@ Library Build-depends:- base >= 4.9 && < 4.21- , containers >= 0.4 && < 0.8+ 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@@ -88,6 +89,7 @@ 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@@ -149,9 +151,10 @@ Main-Is: Unit.hs Build-depends: -- shared dependencies with library- base >= 4.9 && < 4.21- , containers >= 0.4 && < 0.8+ 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@@ -166,7 +169,7 @@ if !flag(examples) { buildable: False }- Build-depends: base, containers, haskeline+ Build-depends: base, containers, haskeline, optparse-applicative Default-Language: Haskell2010 hs-source-dirs: examples Main-Is: Test.hs
− 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) || defined(aarch64_HOST_ARCH)-# define WINDOWS_CCONV ccall-#else-# error Unknown mingw32 arch-#endif--#endif
tests/RunTTY.hs view
@@ -23,11 +23,18 @@ data Invocation = Invocation { prog :: FilePath- , progArgs :: [String]+ -- | 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@@ -41,9 +48,9 @@ setUTF8 :: Invocation -> Invocation-setUTF8 = setLang "en_US.UTF-8"+setUTF8 = setLang "C.UTF-8" setLatin1 :: Invocation -> Invocation-setLatin1 = setLang "en_US.ISO8859-1"+setLatin1 = setLang "C.ISO8859-1" runInvocation :: Invocation@@ -51,11 +58,11 @@ -- simulate real user input and prevent Haskeline -- from coalescing the changes.) -> IO [B.ByteString]-runInvocation Invocation {..} inputs- | runInTTY = runCommandInPty prog progArgs (Just environment) inputs+runInvocation inv@Invocation {..} inputs+ | runInTTY = runCommandInPty prog (progArgs inv) (Just environment) inputs | otherwise = do (Just inH, Just outH, Nothing, ph)- <- createProcess (proc prog progArgs)+ <- createProcess (proc prog (progArgs inv)) { env = Just environment , std_in = CreatePipe , std_out = CreatePipe
tests/Unit.hs view
@@ -16,6 +16,7 @@ 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@@ -34,6 +35,13 @@ 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.@@ -41,23 +49,55 @@ let i = setTerm "xterm" Invocation { prog = p,- progArgs = [],+ progModeArgs = [],+ progInputArgs = [], runInTTY = True, environment = [] }- result <- runTestTT $ test [interactionTests i, fileStyleTests i]+ 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 -interactionTests :: Invocation -> Test-interactionTests i = "interaction" ~: test- [ unicodeEncoding i- , unicodeMovement i- , tabCompletion i- , incorrectInput i- , historyTests i- , inputChar $ setCharInput i- , dumbTests $ setTerm "dumb" i+-- | 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)" ~:@@ -113,7 +153,7 @@ tabCompletion i = "tab completion" ~: [ utf8Test i [ utf8 "tests/dummy-μ\t\t" ] [ prompt 0, utf8 "tests/dummy-μασ/"- <> nl <> utf8 "ςερτ bar" <> nl+ <> nl <> utf8 "bar ςερτ" <> nl <> prompt' 0 <> utf8 "tests/dummy-μασ/" ] ]@@ -186,7 +226,7 @@ ] setCharInput :: Invocation -> Invocation-setCharInput i = i { progArgs = ["chars"] }+setCharInput i = i { progInputArgs = ["chars"] } fileStyleTests :: Invocation -> Test@@ -246,26 +286,28 @@ -- 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 :: Invocation -> Test-dumbTests i = "dumb term" ~:- [ "line input" ~: utf8Test i+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 i+ , "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 i)+ , "line char input" ~: utf8Test (setCharInput ii) [utf8 "xαβ"]- [ prompt' 0, utf8 "x" <> nl <> output 0 (utf8 "x")- <> prompt' 1 <> utf8 "α" <> nl <> output 1 (utf8 "α")- <> prompt' 2 <> utf8 "β" <> nl <> output 2 (utf8 "β")+ [ 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 $ "안기영" -------------@@ -287,7 +329,7 @@ cr = raw [13] nl :: B.ByteString-nl = raw [13,10] -- NB: see fixNL: this is really [13,13,10]+nl = raw [27, 69] output :: Int -> B.ByteString -> B.ByteString output k s = utf8 (T.pack $ "line " ++ show k ++ ":")