System/Console/Haskeline/Vi.hs

    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

    -- If we receive a ^D and the line is empty, return Nothing
    -- otherwise, act like '\n' (mimicing how Readline behaves)
    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 -- 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
                        -- 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)
                        ]

    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
                                -- if no match, bail out.
                                , 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)
                           -- 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)
                           ]
            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
            -- 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
            , 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)
                ------------------
                -- Word movements
                -- move to the start of the next word
                , (simpleChar 'w', goRightUntil $
                                    atStart isWordChar .||. atStart isOtherChar)
                , (simpleChar 'W', goRightUntil (atStart isBigWordChar))
                -- move to the beginning of the previous word
                , (simpleChar 'b', goLeftUntil $
                                    atStart isWordChar .||. atStart isOtherChar)
                , (simpleChar 'B', goLeftUntil (atStart isBigWordChar))
                -- move to the end of the current word
                , (simpleChar 'e', goRightUntil $
                                    atEnd isWordChar .||. atEnd isOtherChar)
                , (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

    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'

    -- This mimics the ctrl-w command in readline's vi mode, which corresponds to
    -- the tty's werase character.
    wordErase :: KillHelper
    wordErase = SimpleMove $ goLeftUntil $ atStart isBigWordChar

    ------------------
    -- Matching braces

    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 = [('(',')'), ('[',']'), ('{','}')]

    ---------------
    -- Replace mode
    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
                    ]

    ---------------------------
    -- Saving previous commands

    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

    -------------------
    -- Vi-style searching

    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, -- TODO: not needed
                                        direction = dir}
        case result of
            Left e -> effect e >> setState cm
            Right sm -> do
                put vstate {lastSearch = toSearch'}
                setState (restore (foundHistory sm))