module System.Console.Haskeline.Vi where
import System.Console.Haskeline.Command
import System.Console.Haskeline.Monads
import System.Console.Haskeline.Key
import System.Console.Haskeline.Command.Completion
import System.Console.Haskeline.Command.History
import System.Console.Haskeline.Command.KillRing
import System.Console.Haskeline.Command.Undo
import System.Console.Haskeline.LineState
import System.Console.Haskeline.InputT
import Data.Char
import Control.Monad(liftM)
type EitherMode = Either CommandMode InsertMode
type SavedCommand m = Command (ViT m) (ArgMode CommandMode) EitherMode
data ViState m = ViState {
lastCommand :: SavedCommand m,
lastSearch :: [Grapheme]
}
emptyViState :: Monad m => ViState m
emptyViState = ViState {
lastCommand = return . Left . argState,
lastSearch = []
}
type ViT m = StateT (ViState m) (InputCmdT m)
type InputCmd s t = forall m . MonadException m => Command (ViT m) s t
type InputKeyCmd s t = forall m . MonadException m => KeyCommand (ViT m) s t
viKeyCommands :: InputKeyCmd InsertMode (Maybe String)
viKeyCommands = choiceCmd [
simpleChar '\n' +> finish
, ctrlChar 'd' +> eofIfEmpty
, simpleInsertions >+> viCommands
, simpleChar '\ESC' +> change enterCommandMode
>|> viCommandActions
]
viCommands :: InputCmd InsertMode (Maybe String)
viCommands = keyCommand viKeyCommands
simpleInsertions :: InputKeyCmd InsertMode InsertMode
simpleInsertions = choiceCmd
[ simpleKey LeftKey +> change goLeft
, simpleKey RightKey +> change goRight
, simpleKey Backspace +> change deletePrev
, simpleKey Delete +> change deleteNext
, simpleKey Home +> change moveToStart
, simpleKey End +> change moveToEnd
, insertChars
, ctrlChar 'l' +> clearScreenCmd
, simpleKey UpKey +> historyBack
, simpleKey DownKey +> historyForward
, searchHistory
, simpleKey KillLine +> killFromHelper (SimpleMove moveToStart)
, ctrlChar 'w' +> killFromHelper wordErase
, completionCmd (simpleChar '\t')
]
insertChars :: InputKeyCmd InsertMode InsertMode
insertChars = useChar $ loop []
where
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
eofIfEmpty :: (Monad m, Save s, Result s) => Command m s (Maybe String)
eofIfEmpty s
| save s == emptyIM = return Nothing
| otherwise = finish s
viCommandActions :: InputCmd CommandMode (Maybe String)
viCommandActions = keyChoiceCmd [
simpleChar '\n' +> finish
, ctrlChar 'd' +> eofIfEmpty
, simpleCmdActions >+> viCommandActions
, exitingCommands >+> viCommands
, repeatedCommands >+> chooseEitherMode
]
where
chooseEitherMode :: InputCmd EitherMode (Maybe String)
chooseEitherMode (Left cm) = viCommandActions cm
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)
]
simpleCmdActions :: InputKeyCmd CommandMode CommandMode
simpleCmdActions = choiceCmd [
simpleChar '\ESC' +> change id
, simpleChar 'r' +> replaceOnce
, simpleChar 'R' +> replaceLoop
, simpleChar 'D' +> noArg >|> killAndStoreCmd (SimpleMove moveToEnd)
, ctrlChar 'l' +> clearScreenCmd
, simpleChar 'u' +> commandUndo
, ctrlChar 'r' +> commandRedo
, 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)
]
replaceOnce :: InputCmd CommandMode CommandMode
replaceOnce = try $ changeFromChar replaceChar
repeatedCommands :: InputKeyCmd CommandMode EitherMode
repeatedCommands = choiceCmd [argumented, doBefore noArg repeatableCommands]
where
start = foreachDigit startArg ['1'..'9']
addDigit = foreachDigit addNum ['0'..'9']
argumented = start >+> loop
loop = keyChoiceCmd [addDigit >+> loop
, repeatableCommands
, withoutConsuming (change argState) >+> return . Left
]
pureMovements :: InputKeyCmd (ArgMode CommandMode) CommandMode
pureMovements = choiceCmd $ charMovements ++ 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)
]
useMovementsForKill :: Command m s t -> (KillHelper -> Command m s t) -> KeyCommand m s t
useMovementsForKill alternate useHelper = choiceCmd $
specialCases
++ map (\(k,move) -> k +> useHelper (SimpleMove move)) movements
where
specialCases = [ simpleChar 'e' +> useHelper (SimpleMove goToWordDelEnd)
, simpleChar 'E' +> useHelper (SimpleMove goToBigWordDelEnd)
, simpleChar '%' +> useHelper (GenericKill deleteMatchingBrace)
, charMovement 'f' $ \c -> goRightUntil $ afterChar (==c)
, charMovement 'F' $ \c -> goLeftUntil $ overChar (==c)
, charMovement 't' $ \c -> goRightUntil $ overChar (==c)
, charMovement 'T' $ \c -> goLeftUntil $ afterChar (==c)
]
charMovement c move = simpleChar c +> keyChoiceCmd [
useChar (useHelper . SimpleMove . move)
, withoutConsuming alternate]
repeatableCommands :: InputKeyCmd (ArgMode CommandMode) EitherMode
repeatableCommands = choiceCmd
[ repeatableCmdToIMode
, repeatableCmdMode >+> return . Left
, simpleChar '.' +> saveForUndo >|> runLastCommand
]
where
runLastCommand s = liftM 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
, pureMovements
]
where
repeatableChange f = storedCmdAction (saveForUndo >|> change (applyArg f))
flipCase :: CommandMode -> CommandMode
flipCase CEmpty = CEmpty
flipCase (CMode xs y zs) = CMode xs (modifyBaseChar flipCaseG y) zs
where
flipCaseG c | isLower c = toUpper c
| otherwise = toLower c
repeatableCmdToIMode :: InputKeyCmd (ArgMode CommandMode) EitherMode
repeatableCmdToIMode = simpleChar 'c' +> deletionToInsertCmd
deletionCmd :: InputCmd (ArgMode CommandMode) CommandMode
deletionCmd = keyChoiceCmd
[ reinputArg >+> deletionCmd
, simpleChar 'd' +> killAndStoreCmd killAll
, useMovementsForKill (change argState) killAndStoreCmd
, withoutConsuming (change argState)
]
deletionToInsertCmd :: InputCmd (ArgMode CommandMode) EitherMode
deletionToInsertCmd = keyChoiceCmd
[ reinputArg >+> deletionToInsertCmd
, simpleChar 'c' +> killAndStoreIE killAll
, simpleChar 'w' +> killAndStoreIE (SimpleMove goToWordDelEnd)
, simpleChar 'W' +> killAndStoreIE (SimpleMove goToBigWordDelEnd)
, useMovementsForKill (liftM Left . change argState) killAndStoreIE
, 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 :: LineState s => InputKeyCmd (ArgMode s) (ArgMode s)
reinputArg = foreachDigit restartArg ['1'..'9'] >+> loop
where
restartArg n = startArg n . argState
loop = keyChoiceCmd
[ foreachDigit addNum ['0'..'9'] >+> loop
, withoutConsuming return
]
goToWordDelEnd, goToBigWordDelEnd :: InsertMode -> InsertMode
goToWordDelEnd = goRightUntil $ atStart (not . isWordChar)
.||. atStart (not . isOtherChar)
goToBigWordDelEnd = goRightUntil $ atStart (not . isBigWordChar)
movements :: [(Key,InsertMode -> InsertMode)]
movements = [ (simpleChar 'h', goLeft)
, (simpleChar 'l', goRight)
, (simpleChar ' ', goRight)
, (simpleKey LeftKey, goLeft)
, (simpleKey RightKey, goRight)
, (simpleChar '0', moveToStart)
, (simpleChar '$', moveToEnd)
, (simpleChar '^', skipRight isSpace . moveToStart)
, (simpleChar '%', findMatchingBrace)
, (simpleChar 'w', goRightUntil $
atStart isWordChar .||. atStart isOtherChar)
, (simpleChar 'W', goRightUntil (atStart isBigWordChar))
, (simpleChar 'b', goLeftUntil $
atStart isWordChar .||. atStart isOtherChar)
, (simpleChar 'B', goLeftUntil (atStart isBigWordChar))
, (simpleChar 'e', goRightUntil $
atEnd isWordChar .||. atEnd isOtherChar)
, (simpleChar 'E', goRightUntil (atEnd isBigWordChar))
]
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
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))
toDigit d = fromEnum d - fromEnum '0'
wordErase :: KillHelper
wordErase = SimpleMove $ goLeftUntil $ atStart isBigWordChar
findMatchingBrace :: InsertMode -> InsertMode
findMatchingBrace (IMode xs (y:ys))
| Just b <- matchingRightBrace yc,
Just ((b':bs),ys') <- scanBraces yc b ys = IMode (bs++[y]++xs) (b':ys')
| Just b <- matchingLeftBrace yc,
Just (bs,xs') <- scanBraces yc b xs = IMode xs' (bs ++ [y]++ys)
where yc = baseChar y
findMatchingBrace im = im
deleteMatchingBrace :: InsertMode -> ([Grapheme],InsertMode)
deleteMatchingBrace (IMode xs (y:ys))
| Just b <- matchingRightBrace yc,
Just (bs,ys') <- scanBraces yc b ys = (y : reverse bs, IMode xs ys')
| Just b <- matchingLeftBrace yc,
Just (bs,xs') <- scanBraces yc b xs = (bs ++ [y], IMode xs' ys)
where yc = baseChar y
deleteMatchingBrace im = ([],im)
scanBraces :: Char -> Char -> [Grapheme] -> Maybe ([Grapheme],[Grapheme])
scanBraces c d = scanBraces' (1::Int) []
where
scanBraces' 0 bs xs = Just (bs,xs)
scanBraces' _ _ [] = Nothing
scanBraces' n bs (x:xs) = scanBraces' m (x:bs) xs
where m | baseChar x == c = n+1
| baseChar x == d = n-1
| otherwise = n
matchingRightBrace, matchingLeftBrace :: Char -> Maybe Char
matchingRightBrace = flip lookup braceList
matchingLeftBrace = flip lookup (map (\(c,d) -> (d,c)) braceList)
braceList :: [(Char,Char)]
braceList = [('(',')'), ('[',']'), ('{','}')]
replaceLoop :: InputCmd CommandMode CommandMode
replaceLoop = saveForUndo >|> change insertFromCommandMode >|> loop
>|> change enterCommandModeRight
where
loop = try (oneReplaceCmd >+> loop)
oneReplaceCmd = choiceCmd [
simpleKey LeftKey +> change goLeft
, simpleKey RightKey +> change goRight
, changeFromChar replaceCharIM
]
storeLastCmd :: Monad m => SavedCommand m -> Command (ViT m) s s
storeLastCmd act = \s -> do
modify $ \vs -> vs {lastCommand = act}
return s
storedAction :: Monad m => SavedCommand m -> SavedCommand m
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
storedIAction :: Monad m => Command (ViT m) (ArgMode CommandMode) InsertMode
-> Command (ViT m) (ArgMode CommandMode) InsertMode
storedIAction act = storeLastCmd (liftM Right . act) >|> act
killAndStoreCmd :: MonadIO m => KillHelper -> Command (ViT m) (ArgMode CommandMode) CommandMode
killAndStoreCmd = 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)
noArg :: Monad m => Command m s (ArgMode s)
noArg = return . startArg 1
data SearchEntry = SearchEntry {
entryState :: InsertMode,
searchChar :: Char
}
searchText :: SearchEntry -> [Grapheme]
searchText SearchEntry {entryState = IMode xs ys} = reverse xs ++ ys
instance LineState SearchEntry where
beforeCursor prefix se = beforeCursor (prefix ++ stringToGraphemes [searchChar se])
(entryState se)
afterCursor = afterCursor . entryState
viEnterSearch :: Monad m => Char -> Direction
-> Command (ViT m) CommandMode CommandMode
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
, 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)
]
viSearchHist :: forall m . Monad m
=> Direction -> [Grapheme] -> Command (ViT m) CommandMode CommandMode
viSearchHist dir toSearch cm = do
vstate :: ViState m <- get
let toSearch' = if null toSearch
then lastSearch vstate
else toSearch
result <- doSearch False SearchMode {
searchTerm = toSearch',
foundHistory = save cm,
direction = dir}
case result of
Left e -> effect e >> setState cm
Right sm -> do
put vstate {lastSearch = toSearch'}
setState (restore (foundHistory sm))