Browse Source

Introduce navigel-method to simplify usages of cl-defmethod

Damien Cassou 2 years ago
Signed by: DamienCassou GPG Key ID: B68746238E59B548
4 changed files with 66 additions and 76 deletions
  1. +2
  2. +13
  3. +29
  4. +22

+ 2
- 0
Makefile View File

@ -7,6 +7,8 @@ LINT_CHECKDOC_FILES=$(wildcard *.el) $(wildcard test/*.el)
LINT_PACKAGE_LINT_FILES=$(wildcard *.el)
LINT_COMPILE_FILES=$(wildcard *.el) $(wildcard test/*.el)
LINT_CHECKDOC_OPTIONS=--eval "(setq checkdoc-arguments-in-order-flag nil)"
# Download makel
@if [ -f ../makel/ ]; then \

+ 13
- 13
examples/navigel-examples-fs.el View File

@ -56,16 +56,16 @@
;; How to get the children of an entity should be specified by
;; overriding the method `navigel-children':
(cl-defmethod navigel-children (directory callback &context (navigel-app navigel-examples-fs))
(navigel-method navigel-examples-fs navigel-children (directory callback)
"Call CALLBACK with the files in DIRECTORY as parameter."
(funcall callback (f-entries directory)))
;; `cl-method' is used to override the methods of navigel. To
;; distinguish this override of `navigel-children' from other
;; overrides made by other navigel clients, above code uses a context
;; specializer. The context specializer is introduced with the
;; `&context' keyword and followed by the name of the application
;; saved in `navigel-app' in the command above.
;; `navigel-method' (which is syntactic sugar around `cl-defmethod')
;; is used to override the methods of navigel. To distinguish this
;; override of `navigel-children' from other overrides made by other
;; navigel clients, the first parameter to `navigel-method' must be
;; the name of the application saved in `navigel-app' in the command
;; above.
;; At this point, you should be able to type `M-x
;; navigel-examples-fs-list-files RET' to get a buffer showing all
@ -81,7 +81,7 @@
;; ".bashrc") as in all file browsers. We can easily change that by
;; overriding the `navigel-name' method:
(cl-defmethod navigel-name (file &context (navigel-app navigel-examples-fs))
(navigel-method navigel-examples-fs navigel-name (file)
(f-filename file))
;; This is much better. With `RET', we can easily navigate from a
@ -90,7 +90,7 @@
;; need to override the `navigel-parent' method whose responsibility
;; is to return the parent entity of the entity passed as parameter:
(cl-defmethod navigel-parent (file &context (navigel-app navigel-examples-fs))
(navigel-method navigel-examples-fs navigel-parent (file)
(f-dirname file))
;; You should now be able to press `^' to go to the parent directory
@ -101,7 +101,7 @@
;; pressing `RET' on a file opens the file itself. This can be done
;; by overriding `navigel-open':
(cl-defmethod navigel-open (file _target &context (navigel-app navigel-examples-fs))
(navigel-method navigel-examples-fs navigel-open (file _target)
(if (f-file-p file)
(find-file file)
@ -122,7 +122,7 @@
;; We now specify the column values for each file by overriding
;; `navigel-entity-to-columns':
(cl-defmethod navigel-entity-to-columns (file &context (navigel-app navigel-examples-fs))
(navigel-method navigel-examples-fs navigel-entity-to-columns (file)
(vector (number-to-string (navigel-examples-fs-size file))
(navigel-name file)))
@ -132,7 +132,7 @@
;; should look like. This is done by overriding
;; `navigel-tablist-format':
(cl-defmethod navigel-tablist-format (_entity &context (navigel-app navigel-examples-fs))
(navigel-method navigel-examples-fs navigel-tablist-format (_entity)
(vector (list "Size (B)" 10 nil :right-align t)
(list "Name" 0 t)))
@ -147,7 +147,7 @@
;; As a final step, we might want to be able to delete files from the
;; file system. This can be done by overriding `navigel-delete':
(cl-defmethod navigel-delete (file &context (navigel-app navigel-examples-fs) &optional callback)
(navigel-method navigel-examples-fs navigel-delete (file &optional callback)
(f-delete file)
(funcall callback))

+ 29
- 0
navigel.el View File

@ -314,6 +314,13 @@ refreshed."
(funcall callback))
(message "Ready!")))))))
(defmacro navigel-method (app name args &rest body)
"Define a method NAME with ARGS and BODY.
This method will only be active if `navigel-app' equals APP."
(declare (indent 3))
`(cl-defmethod ,name ,(navigel--insert-context-in-args app args)
;;; Private functions
@ -381,6 +388,28 @@ The state contains the entity at point, the column of point, and the marked enti
"Compute `navigel-entity' children and list those in the current buffer."
(defun navigel--insert-context-in-args (app args)
"Return an argument list with a &context specializer for APP within ARGS."
(let ((result (list))
(rest-args args))
(catch 'found-special-arg
(while rest-args
(let ((arg (car rest-args)))
(when (symbolp arg)
(when (eq arg '&context)
(throw 'found-special-arg
(append (nreverse result)
`(&context (navigel-app ,app))
(cdr rest-args))))
(when (string= "&" (substring-no-properties (symbol-name arg) 0 1))
(throw 'found-special-arg
(append (nreverse result)
`(&context (navigel-app ,app))
(setq result (cons arg result))
(setq rest-args (cdr rest-args))))
(append (nreverse result) `(&context (navigel-app ,app))))))
;;; Major mode

+ 22
- 63
test/navigel-test.el View File

@ -29,69 +29,28 @@
(require 'cl-lib)
(defvar navigel-run-at-time-calls nil
"Save calls to `run-at-time'.")
(defun navigel-call-run-at-time ()
"Execute each element of `navigel-run-at-time-calls'."
(pcase-dolist (`(,_time ,_repeat ,function ,args) (seq-copy navigel-run-at-time-calls))
(apply function args)
(setq navigel-run-at-time-calls (cdr navigel-run-at-time-calls))))
(defmacro navigel-make-synchronous (&rest body)
"Make `run-at-time' synchronous while executing BODY."
(declare (indent 1))
`(cl-letf (((symbol-function 'run-at-time)
(lambda (time repeat function &rest args)
(setq navigel-run-at-time-calls
(append navigel-run-at-time-calls `((,time ,repeat ,function ,args)))))))
(progn ,@body)
(setq navigel-run-at-time-calls nil))))
(ert-deftest navigel-async-mapcar-sync-mapfn ()
(let ((actual nil))
(lambda (item callback)
(funcall callback (1+ item)))
'(1 2 3)
(lambda (result)
(setq actual result)))
(should (equal (length navigel-run-at-time-calls) 1))
(should (equal actual '(2 3 4))))))
(ert-deftest navigel-async-mapcar-async-mapfn ()
(let ((actual nil))
(lambda (item callback)
(run-at-time item nil callback (1+ item)))
'(1 2 3)
(lambda (result)
(setq actual result)))
(should (equal (length navigel-run-at-time-calls) 3))
(should (equal (length navigel-run-at-time-calls) 1))
(should (equal actual '(2 3 4))))))
(ert-deftest navigel-async-mapc ()
(let ((result (make-vector 3 0))
(callback-called nil))
(lambda (item callback)
(setf (seq-elt result (car item)) (cdr item))
(funcall callback))
(list '(0 . a) '(1 . b) '(2 . c))
(lambda ()
(should (equal result [a b c]))
(setq callback-called t)))
(should (equal (length navigel-run-at-time-calls) 1))
(should callback-called))))
(ert-deftest navigel-insert-context-in-args ()
;; no arguments:
(should (equal
(navigel--insert-context-in-args 'foo '())
'(&context (navigel-app foo))))
;; only mandatory arguments:
(should (equal
(navigel--insert-context-in-args 'foo '(a))
'(a &context (navigel-app foo))))
;; special argument:
(should (equal
(navigel--insert-context-in-args 'foo '(a &optional b))
'(a &context (navigel-app foo) &optional b)))
;; context argument:
(should (equal
(navigel--insert-context-in-args 'foo '(a &context (a b)))
'(a &context (navigel-app foo) (a b))))
;; special + context argument:
(should (equal
(navigel--insert-context-in-args 'foo '(a &context (a b) &optional b))
'(a &context (navigel-app foo) (a b) &optional b)))))
(provide 'navigel-test)
;;; navigel-test.el ends here