diff --git a/Changelog b/Changelog --- a/Changelog +++ b/Changelog @@ -1,3 +1,10 @@ +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 @@ -41,6 +48,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`. diff --git a/System/Console/Haskeline/Command.hs b/System/Console/Haskeline/Command.hs --- a/System/Console/Haskeline/Command.hs +++ b/System/Console/Haskeline/Command.hs @@ -1,7 +1,7 @@ module System.Console.Haskeline.Command( -- * Commands Effect(..), - KeyMap(..), + KeyMap(..), CmdM(..), Command, KeyCommand, @@ -20,10 +20,12 @@ change, changeFromChar, (+>), + useKey, useChar, choiceCmd, keyChoiceCmd, keyChoiceCmdM, + doAfter, doBefore ) where @@ -34,9 +36,9 @@ 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 @@ -91,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 @@ -110,9 +112,15 @@ keyChoiceCmdM :: [KeyMap (CmdM m a)] -> CmdM m a keyChoiceCmdM = GetKey . choiceCmd +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. @@ -155,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 >=>) diff --git a/System/Console/Haskeline/Command/History.hs b/System/Console/Haskeline/Command/History.hs --- a/System/Console/Haskeline/Command/History.hs +++ b/System/Console/Haskeline/Command/History.hs @@ -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) diff --git a/System/Console/Haskeline/Command/KillRing.hs b/System/Console/Haskeline/Command/KillRing.hs --- a/System/Console/Haskeline/Command/KillRing.hs +++ b/System/Console/Haskeline/Command/KillRing.hs @@ -38,17 +38,17 @@ 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 @@ -56,37 +56,37 @@ Save s, Save t) => KillHelper -> Command m s t killFromHelper helper = saveForUndo >=> \oldS -> do - let (gs,newIM) = applyHelper helper (save oldS) + 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) + 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) diff --git a/System/Console/Haskeline/Command/Undo.hs b/System/Console/Haskeline/Command/Undo.hs --- a/System/Console/Haskeline/Command/Undo.hs +++ b/System/Console/Haskeline/Command/Undo.hs @@ -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 - diff --git a/System/Console/Haskeline/LineState.hs b/System/Console/Haskeline/LineState.hs --- a/System/Console/Haskeline/LineState.hs +++ b/System/Console/Haskeline/LineState.hs @@ -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) diff --git a/System/Console/Haskeline/Vi.hs b/System/Console/Haskeline/Vi.hs --- a/System/Console/Haskeline/Vi.hs +++ b/System/Console/Haskeline/Vi.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} #if __GLASGOW_HASKELL__ < 802 {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif @@ -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 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 + 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,57 +190,59 @@ ] 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 @@ -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) @@ -302,12 +345,12 @@ 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] -> 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' @@ -363,8 +406,8 @@ 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 ] @@ -381,22 +424,25 @@ 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,18 +467,17 @@ 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 @@ -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) diff --git a/haskeline.cabal b/haskeline.cabal --- a/haskeline.cabal +++ b/haskeline.cabal @@ -1,6 +1,6 @@ Name: haskeline Cabal-Version: >=1.10 -Version: 0.8.4.0 +Version: 0.8.4.1 Category: User Interfaces License: BSD3 License-File: LICENSE