(require 'magit)
(require 'assoc)
(eval-when-compile (require 'cl))
(defvar magit-key-mode-key-maps '()
"This will be filled lazily with proper `define-key' built
keymaps as they're requested.")
(defvar magit-key-mode-buf-name "*magit-key*"
"Name of the buffer.")
(defvar magit-key-mode-current-args '()
"Will contain the arguments to be passed to git.")
(defvar magit-key-mode-current-options '()
"Will contain the arguments to be passed to git.")
(defvar magit-log-mode-window-conf nil
"Will hold the pre-menu configuration of magit.")
(defvar magit-key-mode-groups
'((logging
(man-page "git-log")
(actions
("l" "Short" magit-log)
("L" "Long" magit-log-long)
("h" "Reflog" magit-reflog)
("rl" "Ranged short" magit-log-ranged)
("rL" "Ranged long" magit-log-long-ranged)
("rh" "Ranged reflog" magit-reflog-ranged))
(switches
("-m" "Only merge commits" "--merges")
("-f" "First parent" "--first-parent")
("-i" "Case insensitive patterns" "-i")
("-pr" "Pickaxe regex" "--pickaxe-regex")
("-n" "Name only" "--name-only")
("-am" "All match" "--all-match")
("-al" "All" "--all"))
(arguments
("=r" "Relative" "--relative=" read-directory-name)
("=c" "Committer" "--committer=" read-from-minibuffer)
("=>" "Since" "--since=" read-from-minibuffer)
("=<" "Before" "--before=" read-from-minibuffer)
("=s" "Pickaxe search" "-S" read-from-minibuffer)
("=a" "Author" "--author=" read-from-minibuffer)
("=g" "Grep" "--grep=" read-from-minibuffer)))
(running
(actions
("!" "Command from root" magit-shell-command)
(":" "Git command" magit-git-command)
("g" "git gui" magit-run-git-gui)
("k" "gitk" magit-run-gitk)))
(fetching
(man-page "git-fetch")
(actions
("f" "Current" magit-fetch-current)
("a" "All" magit-remote-update)
("o" "Other" magit-fetch))
(switches
("-p" "Prune" "--prune")))
(pushing
(man-page "git-push")
(actions
("P" "Push" magit-push)
("t" "Push tags" magit-push-tags))
(switches
("-f" "Force" "--force")
("-d" "Dry run" "-n")
("-u" "Set upstream" "-u")))
(pulling
(man-page "git-pull")
(actions
("F" "Pull" magit-pull))
(switches
("-r" "Rebase" "--rebase")))
(branching
(man-page "git-branch")
(actions
("v" "Branch manager" magit-branch-manager)
("n" "New" magit-create-branch)
("m" "Move" magit-move-branch)
("d" "Delete" magit-delete-branch)
("D" "Force Delete" magit-delete-branch-forced)
("b" "Checkout" magit-checkout)))
(tagging
(man-page "git-tag")
(actions
("t" "Lightweight" magit-tag)
("a" "Annotated" magit-annotated-tag))
(switches
("-f" "Force" "-f")))
(stashing
(man-page "git-stash")
(actions
("z" "Save" magit-stash)
("s" "Snapshot" magit-stash-snapshot))
(switches
("-k" "Keep index" "--keep-index")))
(merging
(man-page "git-merge")
(actions
("m" "Merge" magit-merge))
(switches
("-ff" "Fast-forward only" "--ff-only")
("-nf" "No fast-forward" "--no-ff")
("-nc" "No commit" "--no-commit")
("-sq" "Squash" "--squash"))
(arguments
("-st" "Strategy" "--strategy=" read-from-minibuffer)))
(rewriting
(actions
("b" "Begin" magit-rewrite-start)
("s" "Stop" magit-rewrite-stop)
("a" "Abort" magit-rewrite-abort)
("f" "Finish" magit-rewrite-finish)
("*" "Set unused" magit-rewrite-set-unused)
("." "Set used" magit-rewrite-set-used)))
(submodule
(man-page "git-submodule")
(actions
("u" "Update" magit-submodule-update)
("b" "Both update and init" magit-submodule-update-init)
("i" "Init" magit-submodule-init)
("s" "Sync" magit-submodule-sync)))
(bisecting
(man-page "git-bisect")
(actions
("b" "Bad" magit-bisect-bad)
("g" "Good" magit-bisect-good)
("k" "Skip" magit-bisect-skip)
("l" "Log" magit-bisect-log)
("r" "Reset" magit-bisect-reset)
("s" "Start" magit-bisect-start)
("u" "Run" magit-bisect-run)
("v" "Visualize" magit-bisect-visualize))))
"Holds the key, help, function mapping for the log-mode. If you
modify this make sure you reset `magit-key-mode-key-maps' to
nil.")
(defun magit-key-mode-delete-group (group)
"Delete a group from `magit-key-mode-key-maps'."
(let ((items (assoc group magit-key-mode-groups)))
(when items
;; reset the cache
(setq magit-key-mode-key-maps nil)
;; delete the whole group
(setq magit-key-mode-groups
(delq items magit-key-mode-groups))
;; unbind the defun
(magit-key-mode-de-generate group))
magit-key-mode-groups))
(defun magit-key-mode-add-group (group)
"Add a new group to `magit-key-mode-key-maps'. If there's
already a group of that name then this will completely remove it
and put in its place an empty one of the same name."
(when (assoc group magit-key-mode-groups)
(magit-key-mode-delete-group group))
(setq magit-key-mode-groups
(cons (list group '(actions)) magit-key-mode-groups)))
(defun magit-key-mode-key-defined-p (for-group key)
"If KEY is defined as any of switch, argument or action within
FOR-GROUP then return t"
(catch 'result
(let ((options (magit-key-mode-options-for-group for-group)))
(dolist (type '(actions switches arguments))
(when (assoc key (assoc type options))
(throw 'result t))))))
(defun magit-key-mode-update-group (for-group thing &rest args)
"Abstraction for setting values in `magit-key-mode-key-maps'."
(let* ((options (magit-key-mode-options-for-group for-group))
(things (assoc thing options))
(key (car args)))
(if (cdr things)
(if (magit-key-mode-key-defined-p for-group key)
(error "%s is already defined in the %s group." key for-group)
(setcdr (cdr things) (cons args (cddr things))))
(setcdr things (list args)))
(setq magit-key-mode-key-maps nil)
things))
(defun magit-key-mode-insert-argument (for-group key desc arg read-func)
"Add a new binding (KEY) in FOR-GROUP which will use READ-FUNC
to receive input to apply to argument ARG git is run. DESC should
be a brief description of the binding."
(magit-key-mode-update-group for-group 'arguments key desc arg read-func))
(defun magit-key-mode-insert-switch (for-group key desc switch)
"Add a new binding (KEY) in FOR-GROUP which will add SWITCH to git's
command line when it runs. DESC should be a brief description of
the binding."
(magit-key-mode-update-group for-group 'switches key desc switch))
(defun magit-key-mode-insert-action (for-group key desc func)
"Add a new binding (KEY) in FOR-GROUP which will run command
FUNC. DESC should be a brief description of the binding."
(magit-key-mode-update-group for-group 'actions key desc func))
(defun magit-key-mode-options-for-group (for-group)
"Retrieve the options (switches, commands and arguments) for
the group FOR-GROUP."
(or (cdr (assoc for-group magit-key-mode-groups))
(error "Unknown group '%s'" for-group)))
(defun magit-key-mode-help (for-group)
"Provide help for a key (which the user is prompted for) within
FOR-GROUP."
(let* ((opts (magit-key-mode-options-for-group for-group))
(man-page (cadr (assoc 'man-page opts)))
(seq (read-key-sequence
(format "Enter command prefix%s: "
(if man-page
(format ", `?' for man `%s'" man-page)
""))))
(actions (cdr (assoc 'actions opts))))
(cond
;; if it is an action popup the help for the to-be-run function
((assoc seq actions) (describe-function (nth 2 (assoc seq actions))))
;; if there is "?" show a man page if there is one
((equal seq "?")
(if man-page
(man man-page)
(error "No man page associated with `%s'" for-group)))
(t (error "No help associated with `%s'" seq)))))
(defun magit-key-mode-exec-at-point ()
"Run action/args/option at point."
(interactive)
(let* ((key (or (get-text-property (point) 'key-group-executor)
(error "Nothing at point to do.")))
(def (lookup-key (current-local-map) key)))
(call-interactively def)))
(defun magit-key-mode-jump-to-next-exec ()
"Jump to the next action/args/option point."
(interactive)
(let* ((oldp (point))
(old (get-text-property oldp 'key-group-executor))
(p (if (= oldp (point-max)) (point-min) (1+ oldp))))
(while (let ((new (get-text-property p 'key-group-executor)))
(and (not (= p oldp)) (or (not new) (eq new old))))
(setq p (if (= p (point-max)) (point-min) (1+ p))))
(goto-char p)
(skip-chars-forward " ")))
(defun magit-key-mode-build-keymap (for-group)
"Construct a normal looking keymap for the key mode to use and
put it in magit-key-mode-key-maps for fast lookup."
(let* ((options (magit-key-mode-options-for-group for-group))
(actions (cdr (assoc 'actions options)))
(switches (cdr (assoc 'switches options)))
(arguments (cdr (assoc 'arguments options)))
(map (make-sparse-keymap)))
(suppress-keymap map 'nodigits)
;; ret dwim
(define-key map (kbd "RET") 'magit-key-mode-exec-at-point)
;; tab jumps to the next "button"
(define-key map (kbd "TAB") 'magit-key-mode-jump-to-next-exec)
;; all maps should `quit' with `C-g' or `q'
(define-key map (kbd "C-g") `(lambda ()
(interactive)
(magit-key-mode-command nil)))
(define-key map (kbd "q") `(lambda ()
(interactive)
(magit-key-mode-command nil)))
;; run help
(define-key map (kbd "?") `(lambda ()
(interactive)
(magit-key-mode-help ',for-group)))
(flet ((defkey (k action)
(when (and (lookup-key map (car k))
(not (numberp (lookup-key map (car k)))))
(message "Warning: overriding binding for `%s' in %S"
(car k) for-group)
(ding)
(sit-for 2))
(define-key map (car k)
`(lambda () (interactive) ,action))))
(when actions
(dolist (k actions)
(defkey k `(magit-key-mode-command ',(nth 2 k)))))
(when switches
(dolist (k switches)
(defkey k `(magit-key-mode-add-option ',for-group ,(nth 2 k)))))
(when arguments
(dolist (k arguments)
(defkey k `(magit-key-mode-add-argument
',for-group ,(nth 2 k) ',(nth 3 k))))))
(aput 'magit-key-mode-key-maps for-group map)
map))
(defvar magit-key-mode-prefix nil
"For internal use. Holds the prefix argument to the command
that brought up the key-mode window, so it can be used by the
command that's eventually invoked.")
(defun magit-key-mode-command (func)
(let ((args '()))
;; why can't maphash return a list?!
(maphash (lambda (k v)
(push (concat k (shell-quote-argument v)) args))
magit-key-mode-current-args)
(let ((magit-custom-options (append args magit-key-mode-current-options))
(current-prefix-arg (or current-prefix-arg magit-key-mode-prefix)))
(set-window-configuration magit-log-mode-window-conf)
(when func
(call-interactively func))
(magit-key-mode-kill-buffer))))
(defvar magit-key-mode-current-args nil
"A hash-table of current argument set (which will eventually
make it to the git command-line).")
(defun magit-key-mode-add-argument (for-group arg-name input-func)
(let ((input (funcall input-func (concat arg-name ": "))))
(puthash arg-name input magit-key-mode-current-args)
(magit-key-mode-redraw for-group)))
(defvar magit-key-mode-current-options '()
"Current option set (which will eventually make it to the git
command-line).")
(defun magit-key-mode-add-option (for-group option-name)
"Toggles the appearance of OPTION-NAME in
`magit-key-mode-current-options'."
(if (not (member option-name magit-key-mode-current-options))
(add-to-list 'magit-key-mode-current-options option-name)
(setq magit-key-mode-current-options
(delete option-name magit-key-mode-current-options)))
(magit-key-mode-redraw for-group))
(defun magit-key-mode-kill-buffer ()
(interactive)
(kill-buffer magit-key-mode-buf-name))
(defvar magit-log-mode-window-conf nil
"Pre-popup window configuration.")
(defun magit-key-mode (for-group &optional original-opts)
"Mode for magit key selection. All commands, switches and
options can be toggled/actioned with the key combination
highlighted before the description."
(interactive)
;; save the window config to restore it as was (no need to make this
;; buffer local)
(setq magit-log-mode-window-conf
(current-window-configuration))
;; setup the mode, draw the buffer
(let ((buf (get-buffer-create magit-key-mode-buf-name)))
(delete-other-windows)
(split-window-vertically)
(other-window 1)
(switch-to-buffer buf)
(kill-all-local-variables)
(set (make-local-variable
'magit-key-mode-current-options)
original-opts)
(set (make-local-variable
'magit-key-mode-current-args)
(make-hash-table))
(set (make-local-variable 'magit-key-mode-prefix) current-prefix-arg)
(magit-key-mode-redraw for-group))
(message
(concat
"Type a prefix key to toggle it. Run 'actions' with their prefixes. "
"'?' for more help.")))
(defun magit-key-mode-get-key-map (for-group)
"Get or build the keymap for FOR-GROUP."
(or (cdr (assoc for-group magit-key-mode-key-maps))
(magit-key-mode-build-keymap for-group)))
(defun magit-key-mode-redraw (for-group)
"(re)draw the magit key buffer."
(let ((buffer-read-only nil)
(old-point (point)))
(erase-buffer)
(make-local-variable 'font-lock-defaults)
(use-local-map (magit-key-mode-get-key-map for-group))
(magit-key-mode-draw for-group)
(delete-trailing-whitespace)
(setq mode-name "magit-key-mode" major-mode 'magit-key-mode)
(goto-char old-point))
(setq buffer-read-only t)
(fit-window-to-buffer))
(defun magit-key-mode-draw-header (header)
"Draw a header with the correct face."
(insert (propertize header 'face 'font-lock-keyword-face) "\n"))
(defvar magit-key-mode-args-in-cols nil
"When true, draw arguments in columns as with switches and
options.")
(defun magit-key-mode-draw-args (args)
"Draw the args part of the menu."
(magit-key-mode-draw-buttons
"Args"
args
(lambda (x)
(format "(%s) %s"
(nth 2 x)
(propertize (gethash (nth 2 x) magit-key-mode-current-args "")
'face 'widget-field)))
(not magit-key-mode-args-in-cols)))
(defun magit-key-mode-draw-switches (switches)
"Draw the switches part of the menu."
(magit-key-mode-draw-buttons
"Switches"
switches
(lambda (x)
(format "(%s)" (let ((s (nth 2 x)))
(if (member s magit-key-mode-current-options)
(propertize s 'face 'font-lock-warning-face)
s))))))
(defun magit-key-mode-draw-actions (actions)
"Draw the actions part of the menu."
(magit-key-mode-draw-buttons "Actions" actions nil))
(defun magit-key-mode-draw-buttons (section xs maker
&optional one-col-each)
(when xs
(magit-key-mode-draw-header section)
(magit-key-mode-draw-in-cols
(mapcar (lambda (x)
(let* ((head (propertize (car x) 'face 'font-lock-builtin-face))
(desc (nth 1 x))
(more (and maker (funcall maker x)))
(text (format " %s: %s%s%s"
head desc (if more " " "") (or more ""))))
(propertize text 'key-group-executor (car x))))
xs)
one-col-each)))
(defun magit-key-mode-draw-in-cols (strings one-col-each)
"Given a list of strings, print in columns (using `insert'). If
ONE-COL-EACH is true then don't columify, but rather, draw each
item on one line."
(let ((longest-act (apply 'max (mapcar 'length strings))))
(while strings
(let ((str (car strings)))
(let ((padding (make-string (- (+ longest-act 3) (length str)) ? )))
(insert str)
(if (or one-col-each
(and (> (+ (length padding) ;
(current-column)
longest-act)
(window-width))
(cdr strings)))
(insert "\n")
(insert padding))))
(setq strings (cdr strings))))
(insert "\n"))
(defun magit-key-mode-draw (for-group)
"Function used to draw actions, switches and parameters."
(let* ((options (magit-key-mode-options-for-group for-group))
(switches (cdr (assoc 'switches options)))
(arguments (cdr (assoc 'arguments options)))
(actions (cdr (assoc 'actions options))))
(magit-key-mode-draw-switches switches)
(magit-key-mode-draw-args arguments)
(magit-key-mode-draw-actions actions)
(insert "\n")))
(defun magit-key-mode-de-generate (group)
"Unbind the function for GROUP."
(fmakunbound
(intern (concat "magit-key-mode-popup-" (symbol-name group)))))
(defun magit-key-mode-generate (group)
"Generate the key-group menu for GROUP"
(let ((opts (magit-key-mode-options-for-group group)))
(eval
`(defun ,(intern (concat "magit-key-mode-popup-" (symbol-name group))) nil
,(concat "Key menu for " (symbol-name group))
(interactive)
(magit-key-mode (quote ,group))))))
;; create the interactive functions for the key mode popups (which are
;; applied in the top-level key maps)
(mapc (lambda (g)
(magit-key-mode-generate (car g)))
magit-key-mode-groups)
(provide 'magit-key-mode)
