-- Copyright (c) 2005, 2008 Don Stewart - http://www.cse.unsw.edu.au/~dons -- | An keymap that emulates @mg@, an emacs-like text editor. For more -- information see -- -- A quick summary: -- -- > ^F Forward character -- > ^B Backwards character -- > ^N Next line -- > ^P Previous line -- > ^A Start of line -- > ^E End of line -- > ^D delete current character -- > ^S interactive search forward -- > ^R interactive search backwards -- > ^O Open a new line at cursor position -- > ^T transpose characters -- > ^U Repeat next command 4 times (can be cascaded i.e. ^u^u^f will move -- > 16 characters forward) -- > -- > ^K kill to end of line (placing into kill buffer) -- > ^Y yank kill buffer into current location -- > ^@ set mark -- > ^W kill region (cuts from previously set mark to current location, -- > into kill buffer) -- > M-W copy region (into kill buffer) -- > -- > ^V Next page -- > M-V Previous page -- > M-< start of buffer -- > M-> end of buffer -- -- > ^X^C Quit (you will be asked if you want to save files) -- > ^X-O Next window. -- > ^X-N Next window. -- > ^X-P Previous window. -- > ^X-U Undo. -- -- For more key bindings, type ``M-x describe-bindings''. module Yi.Keymap.Mg (keymap) where import Yi.Yi import Yi.Char import Numeric ( showOct ) import Data.Char ( ord, chr ) import Data.List ((\\), isPrefixOf) import qualified Data.Map as M import Control.Arrow import Control.Exception ( try, evaluate ) import Control.Monad import Control.Monad.Trans import Yi.Debug import Yi.Keymap.Emacs.Utils (findFile, isearchProcess, withMinibuffer, completeFileName) import Yi.Keymap.Emacs.KillRing import Yi.String (dropSpace) ------------------------------------------------------------------------ c_ :: Char -> Char c_ = ctrlLowcase m_ :: Char -> Char m_ = setMeta -- --------------------------------------------------------------------- -- map extended names to corresponding actions -- extended2action :: M.Map String MgMode extended2action = M.fromList [ (ex,a) | (ex,_,a) <- globalTable ] -- -- map keystrokes to extended names -- keys2extended :: M.Map [Char] String keys2extended = M.fromList [ (k,ex) | (ex,ks,_) <- globalTable, k <- ks ] -- -- map chars to actions -- keys2action :: [Char] -> MgMode keys2action ks | Just ex <- M.lookup ks keys2extended , Just a <- M.lookup ex extended2action = a | otherwise = write $ errorEditor $ "No binding for "++ show ks -- -- keystrokes only 1 character long -- unitKeysList :: [Char] unitKeysList = [ k | (_,ks,_) <- globalTable, [k] <- ks ] -- -- C-x mappings -- ctrlxKeysList :: [Char] ctrlxKeysList = [ k | (_,ks,_) <- globalTable, ['\^X',k] <- ks ] -- -- M-O mappings -- metaoKeysList :: [Char] metaoKeysList = [ k | (_,ks,_) <- globalTable, [m,k] <- ks, m == m_ 'O' ] ------------------------------------------------------------------------ -- -- global key/action/name map -- globalTable :: [(String,[String],MgMode)] globalTable = [ ("apropos", [[c_ 'h', 'a']], write $ errorEditor "apropos unimplemented"), ("backward-char", [[c_ 'b'], [m_ 'O', 'D'], [keyLeft]], write $ leftB), ("backward-kill-word", [[m_ '\127']], write $ bkillWordB), ("backward-word", [[m_ 'b']], write $ prevWordB), ("beginning-of-buffer", [[m_ '<']], write $ topB), ("beginning-of-line", [[c_ 'a'], [m_ 'O', 'H']], write $ moveToSol), ("call-last-kbd-macro", [[c_ 'x', 'e']], write $ errorEditor "call-last-kbd-macro unimplemented"), ("capitalize-word", [[m_ 'c']], write $ capitaliseWordB), ("copy-region-as-kill", [[m_ 'w']], write $ errorEditor "copy-region-as-kill unimplemented"), ("delete-backward-char", [['\127'], ['\BS'], [keyBackspace]], write $ bdeleteB), ("delete-blank-lines", [[c_ 'x', c_ 'o']], write $ mgDeleteBlanks), ("delete-char", [[c_ 'd']], write $ deleteN 1), ("delete-horizontal-space", [[m_ '\\']], write $ mgDeleteHorizBlanks), ("delete-other-windows", [[c_ 'x', '1']], write $ closeOtherE), ("delete-window", [[c_ 'x', '0']], write $ closeWindow), ("describe-bindings", [[c_ 'h', 'b']], write $ describeBindings), ("describe-key-briefly", [[c_ 'h', 'c']], describeKeyMode), ("digit-argument", [ [m_ d] | d <- ['0' .. '9'] ], write $ errorEditor "digit-argument unimplemented"), ("dired", [[c_ 'x', 'd']], write $ errorEditor "dired unimplemented"), ("downcase-region", [[c_ 'x', c_ 'l']], write $ errorEditor "downcase-region unimplemented"), ("downcase-word", [[m_ 'l']], write $ lowercaseWordB), ("end-kbd-macro", [[c_ 'x', ')']], write $ errorEditor "end-kbd-macro unimplemented"), ("end-of-buffer", [[m_ '>']], write $ botB), ("end-of-line", [[c_ 'e'], [m_ 'O', 'F']], write $ moveToEol), ("enlarge-window", [[c_ 'x', '^']], write $ enlargeWinE), ("shrink-window", -- not in mg [[c_ 'x', 'v']], write $ shrinkWinE), ("exchange-point-and-mark", [[c_ 'x', c_ 'x']], write $ errorEditor "exchange-point-and-mark unimplemented"), ("execute-extended-command", [[m_ 'x']], metaXSwitch), ("fill-paragraph", [[m_ 'q']], write $ errorEditor "fill-paragraph unimplemented"), ("find-alternate-file", [[c_ 'c', c_ 'v']], write $ errorEditor "find-alternate-file unimplemented"), ("find-file", [[c_ 'x', c_ 'f']], findFile), ("find-file-other-window", [[c_ 'x', '4', c_ 'f']], write $ errorEditor "find-file-other-window unimplemented"), ("forward-char", [[c_ 'f'], [m_ 'O', 'C'], [keyRight]], write $ rightB), ("forward-paragraph", [[m_ ']']], write $ nextNParagraphs 1), ("forward-word", [[m_ 'f']], write $ nextWordB), ("goto-line", [[c_ 'x', 'g']], gotoMode), ("help-help", [[c_ 'h', c_ 'h']], write $ errorEditor "help-help unimplemented"), ("insert-file", [[c_ 'x', 'i']], write $ errorEditor "insert-file unimplemented"), ("isearch-backward", [[c_ 'r']], isearchProcess), ("isearch-forward", [[c_ 's']], isearchProcess), ("just-one-space", [[m_ ' ']], write $ insertN ' '), ("keyboard-quit", [[c_ 'g'], [c_ 'h', c_ 'g'], [c_ 'x', c_ 'g'], [c_ 'x', '4', c_ 'g'], [m_ (c_ 'g')] ], write $ msgEditor "Quit"), ("kill-buffer", [[c_ 'x', 'k']], killBufferMode), ("kill-line", [[c_ 'k']], write $ killLineE), ("kill-region", [[c_ 'w']], write $ errorEditor "kill-region unimplemented"), ("kill-word", [[m_ 'd']], write $ killWordB), ("list-buffers", [[c_ 'x', c_ 'b']], write $ mgListBuffers), ("negative-argument", [[m_ '-']], write $ errorEditor "negative-argument unimplemented"), ("newline", [[c_ 'm']], write $ insertN '\n'), ("newline-and-indent", [], write $ errorEditor "newline-and-indent unimplemented"), ("next-line", [[c_ 'n'], [m_ 'O', 'B'], [keyDown]], -- doesn't remember goal column write $ (execB Move VLine Forward)), ("not-modified", [[m_ '~']], write $ errorEditor "not-modified unimplemented"), ("open-line", [[c_ 'o']], write $ insertB '\n'), ("other-window", [[c_ 'x', 'n'], [c_ 'x', 'o']], write $ nextWinE), ("previous-line", [[c_ 'p'], [m_ 'O', 'A'], [keyUp]], write $ (execB Move VLine Backward)), ("previous-window", [[c_ 'x', 'p']], write $ prevWinE), ("query-replace", [[m_ '%']], write $ errorEditor "query-replace unimplemented"), ("quoted-insert", [[c_ 'q']], insertAnyMode), ("recenter", [[c_ 'l']], write $ errorEditor "recenter unimplemented"), ("save-buffer", [[c_ 'x', c_ 's']], write $ writeFileMode), ("save-buffers-kill-emacs", [[c_ 'x', c_ 'c']], write $ quitEditor), -- should ask to save buffers ("save-some-buffers", [[c_ 'x', 's']], write $ errorEditor "save-some-buffers unimplemented"), ("scroll-down", [[m_ '[', '5', '~'], [m_ 'v'], [keyPPage]], write $ upScreenB), ("scroll-other-window", [[m_ (c_ 'v')]], write $ errorEditor "scroll-other-window unimplemented"), ("scroll-up", [[c_ 'v'], [m_ '[', '6', '~'], [keyNPage]], write $ downScreenB), ("search-backward", [[m_ 'r']], write $ errorEditor "search-backward unimplemented"), ("search-forward", [[m_ 's']], write $ errorEditor "search-forward unimplemented"), ("set-fill-column", [[c_ 'x', 'f']], write $ errorEditor "set-fill-column unimplemented"), ("set-mark-command", [['\NUL']], write $ errorEditor "set-mark-command unimplemented"), ("split-window-vertically", [[c_ 'x', '2']], write $ splitE), ("start-kbd-macro", [[c_ 'x', '(']], write $ errorEditor "start-kbd-macro unimplemented"), ("suspend-emacs", [[c_ 'z']], write $ suspendEditor), ("switch-to-buffer", [[c_ 'x', 'b']], write $ errorEditor "switch-to-buffer unimplemented"), ("switch-to-buffer-other-window", [[c_ 'x', '4', 'b']], write $ errorEditor "switch-to-buffer-other-window unimplemented"), ("transpose-chars", [[c_ 't']], write $ swapB), ("undo", [[c_ 'x', 'u'], ['\^_']], write $ undoB), ("universal-argument", [[c_ 'u']], write $ errorEditor "universal-argument unimplemented"), ("upcase-region", [[c_ 'x', c_ 'u']], write $ errorEditor "upcase-region unimplemented"), ("upcase-word", [[m_ 'u']], write $ uppercaseWordB), ("what-cursor-position", [[c_ 'x', '=']], write $ whatCursorPos), ("write-file", [[c_ 'x', c_ 'w']], writeFileMode), ("yank", [[c_ 'y']], write $ getRegE >>= mapM_ insertN) ] ------------------------------------------------------------------------ type MgMode = Interact Char () keymap :: Keymap keymap = comap eventToChar mode ------------------------------------------------------------------------ -- default bindings mode :: MgMode mode = command +++ ctrlxSwitch +++ metaSwitch +++ metaOSwitch +++ metaXSwitch +++ insert ------------------------------------------------------------------------ -- self insertion insert :: MgMode insert = do c <- satisfy (const True); write $ insertN c -- C- commands command :: MgMode command = do c <- oneOf unitKeysList; keys2action [c] ------------------------------------------------------------------------ -- switch to ctrl-X submap ctrlxSwitch :: MgMode ctrlxSwitch = do event '\^X' ; write (msgEditor "C-x-"); ctrlxMode -- ctrl x submap ctrlxMode :: MgMode ctrlxMode = do c <- oneOf ctrlxKeysList; keys2action ['\^X',c]; write msgClr ------------------------------------------------------------------------ -- -- on escape, we'd also like to switch to M- mode -- -- switch to meta mode metaSwitch :: MgMode metaSwitch = do event '\ESC' ; write (msgEditor "ESC-"); metaMode -- hitting ESC also triggers a meta char -- -- a fake mode. really just looking up the binding for: m_ c -- metaMode :: MgMode metaMode = do c <- oneOf ['\0' .. '\255'] -- not quite right when ((m_ c) `elem` unitKeysList) $ keys2action [m_ c] write msgClr ------------------------------------------------------------------------ -- switch to meta O mode metaOSwitch :: MgMode metaOSwitch = event (m_ 'O') >> write (msgEditor "ESC-O-") >> metaOMode metaOMode :: MgMode metaOMode = do c <- oneOf metaoKeysList; keys2action [m_ 'O',c]; write msgClr -- --------------------------------------------------------------------- -- build a generic line buffer editor, given a mode to transition to -- echoMode :: String -> Interact Char (Maybe String) echoMode prompt = do write (logPutStrLn "echoMode") result <- lineEdit [] write msgClr return result where lineEdit s = do write $ msgEditor (prompt ++ s) (do delete; lineEdit (take (length s - 1) s) +++ do c <- anyButDelNlArrow; lineEdit (s++[c]) +++ do event '\^G'; return Nothing +++ do enter; return (Just s)) anyButDelNlArrow = oneOf $ any' \\ (enter' ++ delete' ++ ['\ESC',keyUp,keyDown]) withLineEditor :: String -> (String -> MgMode) -> MgMode withLineEditor prompt cont = do s <- echoMode prompt case s of Nothing -> return () Just x -> cont x ------------------------------------------------------------------------ -- | execute an extended command -- we ultimately map the command back to a -- keystroke, and execute that. metaXSwitch :: MgMode metaXSwitch = do (event (m_ 'x') +++ event (m_ 'X')); withLineEditor "M-x " metaXEval -- | M-x mode, evaluate a string entered after M-x metaXEval :: String -> MgMode metaXEval cmd = case M.lookup cmd extended2action of Nothing -> write $ msgEditor "[No match]" Just a -> a -- metaXTab :: MgMode ------------------------------------------------------------------------ describeKeyMode :: MgMode describeKeyMode = describeChar "Describe key briefly: " [] describeChar :: String -> String -> MgMode describeChar prompt acc = do c <- anything let keys = acc ++ [c] case M.lookup keys keys2extended of Just ex -> write $ msgEditor $ (printable keys) ++ " runs the command " ++ ex Nothing -> -- only continue if this is the prefix of something in the table if any (isPrefixOf keys) (M.keys keys2extended) then do write $ msgEditor (prompt ++ keys) describeChar prompt keys else write $ msgEditor $ printable keys ++ " is not bound to any function" -- --------------------------------------------------------------------- -- | Writing a file -- writeFileMode :: MgMode writeFileMode = withMinibuffer "Write file: " (completeFileName Nothing) fwriteToE -- --------------------------------------------------------------------- -- | Killing a buffer by name killBufferMode :: MgMode killBufferMode = withLineEditor "Kill buffer: " $ \buf -> write $ do closeBufferE buf -- --------------------------------------------------------------------- -- | Goto a line -- gotoMode :: MgMode gotoMode = withLineEditor "goto line: " $ \l -> write $ do i <- lift $ try . evaluate . read $ l case i of Left _ -> errorEditor "Invalid number" Right i' -> gotoLn i' -- | insert the first character, then switch back to normal mode insertAnyMode :: MgMode insertAnyMode = do c <- oneOf ['\0' .. '\255']; write (insertN c) -- | translate a string into the Emacs encoding of that string printable :: String -> String printable = dropSpace . printable' where printable' ('\ESC':a:ta) = "M-" ++ [a] ++ printable' ta printable' ('\ESC':ta) = "ESC " ++ printable' ta printable' (a:ta) | ord a < 32 = "C-" ++ [chr (ord a + 96)] ++ " " ++ printable' ta | isMeta a = "M-" ++ printable' (clrMeta a:ta) | ord a >= 127 = bigChar a ++ " " ++ printable' ta | otherwise = [a, ' '] ++ printable' ta printable' [] = [] bigChar c | c == keyDown = "> return () where s = unlines [ let p = printable k in p ++ replicate (17 - length p) ' ' ++ ex | (ex,ks,_) <- globalTable , k <- ks ] -- bit of a hack, unfortunately mgListBuffers :: Action mgListBuffers = do closeBufferE name -- close any previous buffer list buffer newBufferE name [] -- new empty one bs <- listBuffersE -- get current list closeBufferE name -- close temporary one newBufferE name (f bs) -- and finally display current one return () where name = "*Buffer List*" f bs = unlines [ " "++(show i)++"\t"++(show n) | (n,i) <- bs ] -- -- delete all blank lines from this point mgDeleteBlanks :: Action mgDeleteBlanks = do p <- getSelectionMarkPointB moveWhileE (== '\n') GoRight q <- getSelectionMarkPointB gotoPointE p deleteNE (q - p) -- not quite right, as it will delete, even if no blanks mgDeleteHorizBlanks :: Action mgDeleteHorizBlanks = do p <- getSelectionMarkPointB moveWhileE (\c -> c == ' ' || c == '\t') GoRight q <- getSelectionMarkPointB gotoPointE p deleteNE (q - p) ------------------------------------------------------------------------ -- -- some regular expressions any', enter', delete' :: [Char] enter' = ['\n', '\r'] delete' = ['\BS', '\127', keyBackspace ] any' = ['\0' .. '\255'] delete, enter, anything :: Interact Char Char delete = oneOf delete' enter = oneOf enter' anything = oneOf any'