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

Add basic error handling

Browse Source 
* hydra.el (defhydra): When the macro fails, message an error and
  continue as if the defhydra call wasn't there.
master
Oleh Krehel 11 years ago
parent 51e7753aea
commit 3d7d8c764f
1 changed files with 111 additions and 107 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 218
      hydra.el

218
hydra.el
Unescape View File

@ -801,113 +801,117 @@ result of `defhydra'."
(setq docstring "hydra"))) (setq docstring "hydra")))
(when (keywordp (car body)) (when (keywordp (car body))
(setq body (cons nil (cons nil body)))) (setq body (cons nil (cons nil body))))
(let* ((keymap (copy-keymap hydra-base-map)) (condition-case err
(keymap-name (intern (format "%S/keymap" name))) (let* ((keymap (copy-keymap hydra-base-map))
(body-name (intern (format "%S/body" name))) (keymap-name (intern (format "%S/keymap" name)))
(body-key (cadr body)) (body-name (intern (format "%S/body" name)))
(body-plist (cddr body)) (body-key (cadr body))
(body-map (or (car body) (body-plist (cddr body))
(plist-get body-plist :bind))) (body-map (or (car body)
(body-pre (plist-get body-plist :pre)) (plist-get body-plist :bind)))
(body-body-pre (plist-get body-plist :body-pre)) (body-pre (plist-get body-plist :pre))
(body-before-exit (or (plist-get body-plist :post) (body-body-pre (plist-get body-plist :body-pre))
(plist-get body-plist :before-exit))) (body-before-exit (or (plist-get body-plist :post)
(body-after-exit (plist-get body-plist :after-exit)) (plist-get body-plist :before-exit)))
(body-color (hydra--body-color body))) (body-after-exit (plist-get body-plist :after-exit))
(hydra--make-funcall body-before-exit) (body-color (hydra--body-color body)))
(hydra--make-funcall body-after-exit) (hydra--make-funcall body-before-exit)
(dolist (h heads) (hydra--make-funcall body-after-exit)
(let ((len (length h))) (dolist (h heads)
(cond ((< len 2) (let ((len (length h)))
(error "Each head should have at least two items: %S" h)) (cond ((< len 2)
((= len 2) (error "Each head should have at least two items: %S" h))
(setcdr (cdr h) ((= len 2)
(list (setcdr (cdr h)
(hydra-plist-get-default body-plist :hint ""))) (list
(setcdr (nthcdr 2 h) (hydra-plist-get-default body-plist :hint "")))
(list :cmd-name (hydra--head-name h name body)))) (setcdr (nthcdr 2 h)
(t (list :cmd-name (hydra--head-name h name body))))
(let ((hint (cl-caddr h))) (t
(unless (or (null hint) (let ((hint (cl-caddr h)))
(stringp hint)) (unless (or (null hint)
(setcdr (cdr h) (cons (stringp hint))
(hydra-plist-get-default body-plist :hint "") (setcdr (cdr h) (cons
(cddr h)))) (hydra-plist-get-default body-plist :hint "")
(let ((hint-and-plist (cddr h))) (cddr h))))
(if (null (cdr hint-and-plist)) (let ((hint-and-plist (cddr h)))
(setcdr hint-and-plist (if (null (cdr hint-and-plist))
(list :cmd-name (setcdr hint-and-plist
(hydra--head-name h name body))) (list :cmd-name
(plist-put (cdr hint-and-plist) (hydra--head-name h name body)))
:cmd-name (plist-put (cdr hint-and-plist)
(hydra--head-name h name body))))))))) :cmd-name
(let ((doc (hydra--doc body-key body-name heads)) (hydra--head-name h name body)))))))))
(heads-nodup (hydra--delete-duplicates heads))) (let ((doc (hydra--doc body-key body-name heads))
(mapc (heads-nodup (hydra--delete-duplicates heads)))
(lambda (x) (mapc
(define-key keymap (kbd (car x)) (lambda (x)
(plist-get (cl-cdddr x) :cmd-name))) (define-key keymap (kbd (car x))
heads) (plist-get (cl-cdddr x) :cmd-name)))
(hydra--make-funcall body-pre) heads)
(hydra--make-funcall body-body-pre) (hydra--make-funcall body-pre)
(when (memq body-color '(amaranth pink)) (hydra--make-funcall body-body-pre)
(unless (cl-some (when (memq body-color '(amaranth pink))
(lambda (h) (unless (cl-some
(memq (hydra--head-color h body) '(blue teal))) (lambda (h)
heads) (memq (hydra--head-color h body) '(blue teal)))
(error heads)
"An %S Hydra must have at least one blue head in order to exit" (error
body-color))) "An %S Hydra must have at least one blue head in order to exit"
`(progn body-color)))
;; create keymap `(progn
(set (defvar ,keymap-name ;; create keymap
nil (set (defvar ,keymap-name
,(format "Keymap for %S." name)) nil
',keymap) ,(format "Keymap for %S." name))
;; create defuns ',keymap)
,@(mapcar ;; create defuns
(lambda (head) ,@(mapcar
(hydra--make-defun name body doc head keymap-name (lambda (head)
body-pre (hydra--make-defun name body doc head keymap-name
body-before-exit body-pre
body-after-exit)) body-before-exit
heads-nodup) body-after-exit))
;; free up keymap prefix heads-nodup)
,@(unless (or (null body-key) ;; free up keymap prefix
(null body-map) ,@(unless (or (null body-key)
(hydra--callablep body-map)) (null body-map)
`((unless (keymapp (lookup-key ,body-map (kbd ,body-key))) (hydra--callablep body-map))
(define-key ,body-map (kbd ,body-key) nil)))) `((unless (keymapp (lookup-key ,body-map (kbd ,body-key)))
;; bind keys (define-key ,body-map (kbd ,body-key) nil))))
,@(delq nil ;; bind keys
(mapcar ,@(delq nil
(lambda (head) (mapcar
(let ((name (hydra--head-property head :cmd-name))) (lambda (head)
(when (and (cadr head) (let ((name (hydra--head-property head :cmd-name)))
(or body-key body-map)) (when (and (cadr head)
(let ((bind (hydra--head-property head :bind body-map)) (or body-key body-map))
(final-key (let ((bind (hydra--head-property head :bind body-map))
(if body-key (final-key
(vconcat (kbd body-key) (kbd (car head))) (if body-key
(kbd (car head))))) (vconcat (kbd body-key) (kbd (car head)))
(cond ((null bind) nil) (kbd (car head)))))
((hydra--callablep bind) (cond ((null bind) nil)
`(funcall ,bind ,final-key (function ,name))) ((hydra--callablep bind)
((and (symbolp bind) `(funcall ,bind ,final-key (function ,name)))
(if (boundp bind) ((and (symbolp bind)
(keymapp (symbol-value bind)) (if (boundp bind)
t)) (keymapp (symbol-value bind))
`(define-key ,bind ,final-key (function ,name))) t))
(t `(define-key ,bind ,final-key (function ,name)))
(error "Invalid :bind property `%S' for head %S" bind head))))))) (t
heads)) (error "Invalid :bind property `%S' for head %S" bind head)))))))
(defun ,(intern (format "%S/hint" name)) () heads))
,(hydra--message name body docstring heads)) (defun ,(intern (format "%S/hint" name)) ()
,(hydra--make-defun ,(hydra--message name body docstring heads))
name body doc '(nil body) ,(hydra--make-defun
keymap-name name body doc '(nil body)
(or body-body-pre body-pre) body-before-exit keymap-name
'(setq prefix-arg current-prefix-arg)))))) (or body-body-pre body-pre) body-before-exit
'(setq prefix-arg current-prefix-arg)))))
(error
(message "Error in defhydra %S: %s" name (cdr err))
nil)))
(defmacro defhydradio (name _body &rest heads) (defmacro defhydradio (name _body &rest heads)
"Create radios with prefix NAME. "Create radios with prefix NAME.

Write Preview
Loading…
Cancel
Save