yi-0.3: Yi/Keymap/Mg.hs
-- 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 <http://www.openbsd.org/cgi-bin/man.cgi?query=mg>
--
-- 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 = "<down"
| c == keyUp = "<up>"
| c == keyLeft = "<left>"
| c == keyRight = "<right>"
| c == keyNPage = "<pagedown>"
| c == keyPPage = "<pageup>"
| c == '\127' = "<delete>"
| otherwise = show c
------------------------------------------------------------------------
-- Mg-specific actions
whatCursorPos :: Action
whatCursorPos = do
bufInfo <- bufInfoB
let ln = bufInfoLineNo bufInfo
col = bufInfoColNo bufInfo
pt = bufInfoCharNo bufInfo
pct = bufInfoPercent bufInfo
c <- readB
msgEditor $ "Char: "++[c]++" (0"++showOct (ord c) ""++
") point="++show pt++
"("++pct++
") line="++show ln++
" row=? col="++ show col
describeBindings :: Action
describeBindings = newBufferE "*help*" s >> 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'