wilderjds
/
hydra
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

hydra.el (hydra--head-color): Remove

Browse Source 
* hydra.el (hydra-fontify-head-default): Move `hydra--head-color' body
  here.
(hydra-fontify-head-greyscale): Simplify.
(hydra--make-defun): Simplify.
(hydra--head-name): Simplify.
(hydra--delete-duplicates): Update.
(defhydra): Update.
master
Oleh Krehel 11 years ago
parent d71386b0f5
commit 88f14a04a3
2 changed files with 32 additions and 65 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 26
      hydra-test.el
  2. 71
      hydra.el

26
hydra-test.el
Unescape View File

@ -1029,32 +1029,6 @@ _f_ auto-fill-mode: %`auto-fill-function
(buffer-narrowed-p)))
"[[q]]: cancel"))))
(ert-deftest hydra-compat-colors-1 ()
(should (equal (hydra--head-color
'("e" (message "Exiting now") "blue" :exit t)
'(nil nil :color blue))
'blue))
(should (equal (hydra--head-color
'("c" (message "Continuing") "red" :color red)
'(nil nil :color blue))
'red))
(should (equal (hydra--head-color
'("j" next-line "" :exit t)
'(nil nil))
'blue))
(should (equal (hydra--head-color
'("c" (message "Continuing") "red" :exit nil)
'(nil nil :exit t))
'red))
(equal (hydra--head-color
'("a" abbrev-mode nil :exit t)
'(nil nil :color teal))
'teal)
(equal (hydra--head-color
'("a" abbrev-mode :exit nil)
'(nil nil :color teal))
'amaranth))
(ert-deftest hydra-compat-colors-2 ()
(should
(equal

71
hydra.el
Unescape View File

@ -330,24 +330,6 @@ one of the properties on the list."
Return DEFAULT if PROP is not in H."
(hydra-plist-get-default (cl-cdddr h) prop default))
(defun hydra--head-color (h body)
"Return the color of a Hydra head H with BODY."
(let* ((foreign-keys (hydra--body-foreign-keys body))
(head-exit (hydra--head-property h :exit))
(head-color
(if head-exit
(if (eq foreign-keys 'warn)
'teal
'blue)
(cl-case foreign-keys
(warn 'amaranth)
(run 'pink)
(t 'red)))))
(when (and (null (cadr h))
(not (eq head-color 'blue)))
(hydra--complain "nil cmd can only be blue"))
head-color))
(defun hydra--body-foreign-keys (body)
"Return what BODY does with a non-head binding."
(or
@ -423,23 +405,36 @@ BODY, and HEADS are parameters to `defhydra'."
(defun hydra-fontify-head-default (head body)
"Produce a pretty string from HEAD and BODY.
HEAD's binding is returned as a string with a colored face."
(propertize (car head) 'face
(cl-case (hydra--head-color head body)
(blue 'hydra-face-blue)
(red 'hydra-face-red)
(amaranth 'hydra-face-amaranth)
(pink 'hydra-face-pink)
(teal 'hydra-face-teal)
(t (error "Unknown color for %S" head)))))
(let* ((foreign-keys (hydra--body-foreign-keys body))
(head-exit (hydra--head-property head :exit))
(head-color
(if head-exit
(if (eq foreign-keys 'warn)
'teal
'blue)
(cl-case foreign-keys
(warn 'amaranth)
(run 'pink)
(t 'red)))))
(when (and (null (cadr head))
(not (eq head-color 'blue)))
(hydra--complain "nil cmd can only be blue"))
(propertize (car head) 'face
(cl-case head-color
(blue 'hydra-face-blue)
(red 'hydra-face-red)
(amaranth 'hydra-face-amaranth)
(pink 'hydra-face-pink)
(teal 'hydra-face-teal)
(t (error "Unknown color for %S" head))))))
(defun hydra-fontify-head-greyscale (head body)
"Produce a pretty string from HEAD and BODY.
HEAD's binding is returned as a string wrapped with [] or {}."
(let ((color (hydra--head-color head body)))
(format
(if (eq color 'blue)
"[%s]"
"{%s}") (car head))))
(format
(if (hydra--head-property head :exit)
"[%s]"
"{%s}") (car head)))
(defun hydra-fontify-head (head body)
"Produce a pretty string from HEAD and BODY."
@ -533,8 +528,6 @@ BODY-AFTER-EXIT is added to the end of the wrapper."
(cmd (when (car head)
(hydra--make-callable
(cadr head))))
(color (when (car head)
(hydra--head-color head body)))
(doc (if (car head)
(format "%s\n\nCall the head: `%S'." doc (cadr head))
doc))
@ -546,7 +539,7 @@ BODY-AFTER-EXIT is added to the end of the wrapper."
(interactive)
(hydra-default-pre)
,@(when body-pre (list body-pre))
,@(if (memq color '(blue teal))
,@(if (hydra--head-property head :exit)
`((hydra-keyboard-quit)
,(if body-after-exit
`(unwind-protect
@ -586,7 +579,7 @@ BODY-AFTER-EXIT is added to the end of the wrapper."
(if (symbolp (cadr h))
(cadr h)
(concat "lambda-" (car h))))))
(when (and (memq (hydra--head-color h body) '(blue teal))
(when (and (hydra--head-property h :exit)
(not (memq (cadr h) '(body nil))))
(setq str (concat str "-and-exit")))
(intern str)))
@ -594,15 +587,15 @@ BODY-AFTER-EXIT is added to the end of the wrapper."
(defun hydra--delete-duplicates (heads)
"Return HEADS without entries that have the same CMD part.
In duplicate HEADS, :cmd-name is modified to whatever they duplicate."
(let ((ali '(((hydra-repeat . red) . hydra-repeat)))
(let ((ali '(((hydra-repeat . nil) . hydra-repeat)))
res entry)
(dolist (h heads)
(if (setq entry (assoc (cons (cadr h)
(hydra--head-color h '(nil nil)))
(hydra--head-property h :exit))
ali))
(setf (cl-cdddr h) (plist-put (cl-cdddr h) :cmd-name (cdr entry)))
(push (cons (cons (cadr h)
(hydra--head-color h '(nil nil)))
(hydra--head-property h :exit))
(plist-get (cl-cdddr h) :cmd-name))
ali)
(push h res)))
@ -837,7 +830,7 @@ result of `defhydra'."
(when (memq body-foreign-keys '(run warn))
(unless (cl-some
(lambda (h)
(memq (hydra--head-color h body) '(blue teal)))
(hydra--head-property h :exit))
heads)
(error
"An %S Hydra must have at least one blue head in order to exit"

Write Preview
Loading…
Cancel
Save