├── .gitignore ├── LICENSE ├── nhooks.asd ├── nhooks.lisp ├── package.lisp ├── readme.org └── tests ├── package.lisp └── tests.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore compiled lisp files 2 | *.FASL 3 | *.fasl 4 | *.fas 5 | *.lisp-temp 6 | *.dfsl 7 | *.pfsl 8 | *.d64fsl 9 | *.p64fsl 10 | *.lx64fsl 11 | *.lx32fsl 12 | *.dx64fsl 13 | *.dx32fsl 14 | *.fx64fsl 15 | *.fx32fsl 16 | *.sx64fsl 17 | *.sx32fsl 18 | *.wx64fsl 19 | *.wx32fsl 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022 Qiantan Hong 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /nhooks.asd: -------------------------------------------------------------------------------- 1 | ;;;; nhooks.asd 2 | ;;; Adapted from serapeum/contrib/hooks 3 | 4 | (defsystem "nhooks" 5 | :version "1.2.2" 6 | :description "Improved hooks facility inspired by Serapeum." 7 | :author "Qiantan Hong " 8 | :homepage "https://github.com/atlas-engineer/nhooks" 9 | :bug-tracker "https://github.com/atlas-engineer/nhooks/issues" 10 | :source-control (:git "https://github.com/atlas-engineer/nhooks.git") 11 | :license "MIT" 12 | :depends-on ("bordeaux-threads" "serapeum" "closer-mop") 13 | :components ((:file "package") 14 | (:file "nhooks")) 15 | :in-order-to ((test-op (test-op "nhooks/tests")))) 16 | 17 | (defsystem "nhooks/tests" 18 | :depends-on ("nhooks" "lisp-unit2") 19 | :serial t 20 | :pathname "tests/" 21 | :components ((:file "package") 22 | (:file "tests")) 23 | :perform (test-op (op c) 24 | (eval-input 25 | "(lisp-unit2:run-tests 26 | :package :nhooks/tests 27 | :run-contexts #'lisp-unit2:with-summary-context)"))) 28 | -------------------------------------------------------------------------------- /nhooks.lisp: -------------------------------------------------------------------------------- 1 | (in-package :nhooks) 2 | 3 | (defclass handler () 4 | ((name :initarg :name 5 | :accessor name 6 | :type symbol 7 | :initform nil 8 | :documentation " 9 | Name of the handler. 10 | It defaults to the function name if `fn' is a named function. 11 | This is useful so that the user can build handlers out of anonymous functions.") 12 | (description :initarg :description 13 | :accessor description 14 | :type string 15 | :initform "" 16 | :documentation " 17 | Description of the handler. This is purely informative.") 18 | (fn :initarg :fn 19 | :accessor fn 20 | :type function 21 | :initform (required-argument 'fn) 22 | :documentation " 23 | The handler function. It can be an anonymous function.") 24 | (place :initarg :place 25 | :accessor place 26 | :type (or symbol list) 27 | :initform nil 28 | :documentation " 29 | If the handler is meant to be a setter, PLACE describes what is set. 30 | PLACE can be a symbol or a pair (CLASS SLOT). 31 | This can be left empty if the handler is not a setter.") 32 | (value :initarg :value 33 | :accessor value 34 | :type t 35 | :initform nil 36 | :documentation " 37 | If the handler is meant to be a setter, VALUE can be used to describe what FN is 38 | going to set to PLACE. 39 | In particular, PLACE and VALUE can be used to compare handlers. 40 | This can be left empty if the handler is not a setter.")) 41 | (:metaclass closer-mop:funcallable-standard-class) 42 | (:documentation "Handlers are wrappers around functions used in typed hooks. 43 | They serve two purposes as opposed to regular functions: 44 | 45 | - They can embed a NAME so that anonymous functions can be conveniently used in hooks. 46 | - If the handler is meant to be a setter, the PLACE and VALUE slots can be used 47 | to identify and compare setters. 48 | 49 | With this extra information, it's possible to compare handlers and, in particular, avoid duplicates in hooks. 50 | 51 | Handlers are `funcall'able. If you subclass those, don't forget to add 52 | a `closer-mop:funcallable-standard-class' to retain this property.")) 53 | 54 | (defmethod print-object ((handler handler) stream) 55 | (print-unreadable-object (handler stream :type t :identity t) 56 | (format stream "~a" (name handler)))) 57 | 58 | (defun probe-ftype (function ftype) 59 | "Invoke compiler to probe the type of FUNCTION. 60 | 61 | If type of FUNCTION contradicts with FTYPE, raise an error. 62 | 63 | If FTYPE is nil, nothing is done." 64 | (when ftype 65 | (handler-case 66 | (let ((*error-output* (make-broadcast-stream))) ;; silence! 67 | (compile nil 68 | `(lambda () 69 | (let ((fn ,function)) 70 | (declare (type ,ftype fn)) 71 | fn)))) 72 | (style-warning (c) 73 | (error "Handler function ~a does not match expected type ~a. 74 | Detail: ~a" function ftype c)))) 75 | (values)) 76 | 77 | (defmethod initialize-instance :after ((handler handler) &key &allow-other-keys) 78 | (closer-mop:set-funcallable-instance-function 79 | handler (lambda (&rest args) 80 | (apply (fn handler) args))) 81 | (with-slots (name fn) handler 82 | (setf name (or name (name fn))) 83 | (unless name 84 | (error "Can't make a handler without a name")))) 85 | 86 | (defmethod equals ((fn1 handler) (fn2 handler)) 87 | "Return non-nil if FN1 and FN2 are equal. 88 | Handlers are equal if they are setters of the same place and same value, or if 89 | their names are equal." 90 | (cond 91 | ((or (and (place fn1) 92 | (not (place fn2))) 93 | (and (place fn2) 94 | (not (place fn1)))) 95 | nil) 96 | ((and (place fn1) 97 | (place fn2)) 98 | (and (equal (place fn1) 99 | (place fn2)) 100 | (equal (value fn1) 101 | (value fn2)))) 102 | (t 103 | (eq (name fn1) 104 | (name fn2))))) 105 | 106 | (defmethod equals ((h handler) (f function)) (eq (name h) (name f))) 107 | (defmethod equals ((f function) (h handler)) (eq (name h) (name f))) 108 | (defmethod equals ((f1 function) (f2 function)) (eq (name f1) (name f2))) 109 | (defmethod equals (obj (fn handler)) (eq (name fn) obj)) 110 | (defmethod equals ((fn handler) obj) (eq (name fn) obj)) 111 | (defmethod equals (obj (fn function)) (eq (name fn) obj)) 112 | (defmethod equals ((fn function) obj) (eq (name fn) obj)) 113 | (defmethod equals (obj1 obj2) (eq obj1 obj2)) 114 | 115 | (defmethod name ((symbol symbol)) symbol) 116 | (defmethod name ((fn function)) 117 | (let ((fname (nth-value 2 (function-lambda-expression fn)))) 118 | (when (and (symbolp fname) 119 | (not (keywordp fname))) 120 | fname))) 121 | (defmethod fn ((symbol symbol)) (symbol-function symbol)) 122 | (defmethod fn ((function function)) function) 123 | (defmethod description ((symbol symbol)) (documentation symbol 'function)) 124 | 125 | (defclass hook () 126 | ((handler-type :initarg :handler-type 127 | :reader handler-type 128 | :initform nil 129 | :documentation 130 | "The exptected function type of handlers.") 131 | (handlers-alist :initarg :handlers-alist 132 | :accessor handlers-alist 133 | :type list 134 | :initform '() 135 | :documentation "A list with elements of the form (HANDLER . ENABLE-P). 136 | 137 | `run-hook' only runs HANDLERs associated with non nil ENABLE-P. This 138 | is useful it the user wishes to disable some or all handlers without 139 | removing them from the hook.") 140 | (combination :initarg :combination 141 | :accessor combination 142 | :type (or symbol function) 143 | :initform #'default-combine-hook 144 | :documentation " 145 | This can be used to reverse the execution order, return a single value, etc.")) 146 | (:metaclass closer-mop:funcallable-standard-class) 147 | (:documentation "This hook class serves as support for typed-hook. 148 | 149 | Typing in hook is crucial to guarantee that a hook is well formed, i.e. that 150 | its handlers accept the right argument types and return the right value types. 151 | 152 | Hooks are `funcall'able. If you subclass those, don't forget to add a 153 | `closer-mop:funcallable-standard-class' to retain this 154 | property. `define-hook-type' does that for you.")) 155 | 156 | (defmethod initialize-instance :after ((hook hook) &key handlers disabled-handlers &allow-other-keys) 157 | (closer-mop:set-funcallable-instance-function hook (alexandria:curry #'run-hook hook)) 158 | (setf (handlers-alist hook) 159 | (append (mapcar (alexandria:rcurry #'cons t) handlers) 160 | (mapcar (alexandria:rcurry #'cons nil) disabled-handlers) 161 | (handlers-alist hook))) 162 | (dolist (handler (mapcar #'first (handlers-alist hook))) 163 | (restart-case 164 | (probe-ftype (fn handler) (handler-type hook)) 165 | (remove-handler () :report "Remove this handler." 166 | (remove-hook hook handler)) 167 | (reckless-continue () :report "Retain this handler nonetheless.")))) 168 | 169 | (defgeneric handlers (hook) 170 | (:method ((hook hook)) 171 | (mapcar #'first (remove-if-not #'rest (handlers-alist hook)))) 172 | (:documentation "All the enabled handlers.")) 173 | 174 | (defgeneric disabled-handlers (hook) 175 | (:method ((hook hook)) 176 | (mapcar #'first (remove-if #'rest (handlers-alist hook)))) 177 | (:documentation "All the disabled handlers.")) 178 | 179 | (defmacro with-disable-handler-restart ((handler) &body body) 180 | "This is intended to wrap all handler executions." 181 | `(restart-case 182 | (progn ,@body) 183 | (disable-handler () 184 | :report 185 | (lambda (stream) 186 | (format stream "Disable handler ~a which causes the error." ,handler)) 187 | (disable-hook *hook* ,handler)))) 188 | 189 | (defgeneric default-combine-hook (hook &rest args) 190 | (:method ((hook hook) &rest args) 191 | (mapcan (lambda (handler-entry) 192 | (when (cdr handler-entry) 193 | (with-disable-handler-restart ((first handler-entry)) 194 | (with-hook-restart 195 | (list (apply (first handler-entry) args)))))) 196 | (handlers-alist hook))) 197 | (:documentation "Return the list of the results of the HOOK handlers applied from youngest to 198 | oldest to ARGS. 199 | Return '() when there is no handler. 200 | This is an acceptable `combination' for `hook'.")) 201 | 202 | (defgeneric combine-hook-until-failure (hook &rest args) 203 | (:method ((hook hook) &rest args) 204 | (let ((result nil)) 205 | (loop for (handler . enable-p) in (handlers-alist hook) 206 | when enable-p 207 | do (let ((res (with-disable-handler-restart (handler) 208 | (with-hook-restart 209 | (apply handler args))))) 210 | (push res result) 211 | (unless res (return)))) 212 | (nreverse result))) 213 | (:documentation "Return the list of values until the first nil result. 214 | Handlers after the failing one are not run. 215 | 216 | This is an acceptable `combination' for `hook'.")) 217 | 218 | (defgeneric combine-hook-until-success (hook &rest args) 219 | (:method ((hook hook) &rest args) 220 | (loop for (handler . enable-p) in (handlers-alist hook) 221 | thereis (and enable-p 222 | (with-disable-handler-restart (handler) 223 | (with-hook-restart 224 | (apply handler args)))))) 225 | (:documentation "Return the value of the first non-nil result. 226 | Handlers after the successful one are not run. 227 | 228 | You need to check if the hook has handlers to know if a NIL return value is due 229 | to all handlers failing or an empty hook. 230 | 231 | This is an acceptable `combination' for `hook'.")) 232 | 233 | (defgeneric combine-composed-hook (hook &rest args) 234 | (:method ((hook hook) &rest args) 235 | (let ((result args) 236 | (reversed-alist (reverse (handlers-alist hook)))) 237 | (loop for (handler . enable-p) in reversed-alist 238 | when enable-p 239 | do (with-disable-handler-restart (handler) 240 | (with-hook-restart 241 | (setf result (multiple-value-list (apply handler result)))))) 242 | (values-list result))) 243 | (:documentation "Return the result of the composition of the HOOK handlers on ARGS, from 244 | oldest to youngest. 245 | Without handler, return ARGS as values. 246 | This is an acceptable `combination' for `hook'.")) 247 | 248 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 249 | (defun add-hook-internal (hook handler &key append) 250 | "Add HANDLER to HOOK. 251 | Return HOOK. 252 | 253 | If APPEND is non-nil, HANDLER is added at the end. If HANDLER is 254 | already present in HOOK, move it to the front (or end if APPEND is 255 | non-nil) of `handler-alist' and ensure it is enabled." 256 | (serapeum:synchronized (hook) 257 | (alexandria:when-let ((old-handler (assoc handler (handlers-alist hook) :test #'equals))) 258 | (remove-hook hook (first old-handler))) 259 | (if append 260 | (alexandria:appendf (handlers-alist hook) (list (cons handler t))) 261 | (push (cons handler t) (handlers-alist hook))) 262 | hook)) 263 | 264 | (declaim (ftype (function ((or handler function symbol) list &optional boolean) 265 | (or handler function boolean)) 266 | find-handler)) 267 | (defun find-handler (handler-or-name handlers &optional include-disabled) 268 | "Return handler matching HANDLER-OR-NAME in HANDLERS sequence. 269 | 270 | If INCLUDE-DISABLED is non-nil, search both enabled and disabled 271 | handlers. Otherwise, search only enabled handlers." 272 | (if include-disabled 273 | (car (assoc handler-or-name handlers :test #'equals)) 274 | (find handler-or-name handlers :test #'equals))) 275 | 276 | (defmethod remove-hook ((hook hook) handler-or-name) 277 | "Remove handler entry matching HANDLER-OR-NAME from handlers-alist in HOOK. 278 | HANDLER-OR-NAME is either a handler object or a symbol. Return HOOK's 279 | handlers-alist." 280 | (serapeum:synchronized (hook) 281 | (let ((handler-entry (assoc handler-or-name (handlers-alist hook) :test #'equals))) 282 | (when handler-entry 283 | (setf (handlers-alist hook) 284 | (delete handler-entry (handlers-alist hook))))) 285 | (handlers-alist hook))) 286 | 287 | (defgeneric run-hook (hook &rest args) 288 | (:method ((hook hook) &rest args) 289 | (let ((*hook* hook)) 290 | (apply (combination hook) hook args))) 291 | (:documentation "Invoke all the HOOK handlers with the default `combination'. 292 | 293 | Alternatively, use `funcall' of the hook for the same effect.")) 294 | 295 | (defgeneric run-hook-with-args-until-failure (hook &rest args) 296 | (:method ((hook hook) &rest args) 297 | (apply #'combine-hook-until-failure hook args)) 298 | (:documentation "This is equivalent to setting the combination function to 299 | `combine-hook-until-failure' and calling `run-hook'.")) 300 | 301 | (defgeneric run-hook-with-args-until-success (hook &rest args) 302 | (:method ((hook hook) &rest args) 303 | (apply #'combine-hook-until-success hook args)) 304 | (:documentation "This is equivalent to setting the combination function to 305 | `combine-hook-until-success' and calling `run-hook'.")) 306 | 307 | (defgeneric disable-hook (hook &rest handlers) 308 | (:method ((hook hook) &rest handlers) 309 | (serapeum:synchronized (hook) 310 | (dolist (handler-entry (handlers-alist hook)) 311 | (when (or (not handlers) 312 | (member (first handler-entry) handlers :test #'equals)) 313 | (rplacd handler-entry nil))))) 314 | (:documentation "Disable HANDLERS. 315 | Without HANDLERS, disable all of them.")) 316 | 317 | (defgeneric enable-hook (hook &rest handlers) 318 | (:method ((hook hook) &rest handlers) 319 | (serapeum:synchronized (hook) 320 | (dolist (handler-entry (handlers-alist hook)) 321 | (when (or (not handlers) 322 | (member (first handler-entry) handlers :test #'equals)) 323 | (rplacd handler-entry t))))) 324 | (:documentation "Enable HANDLERS. 325 | Without HANDLERS, enable all of them.")) 326 | 327 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 328 | ;; Global hooks. 329 | 330 | ;; TODO: cl-hooks uses symbol properties. Is it a good idea? 331 | (defvar %hook-table (make-hash-table :test #'equal) 332 | "Global hook table.") 333 | 334 | (defun define-hook (hook-type name &key object handlers disabled-handlers combination) 335 | "Return a globally-accessible hook. 336 | The hook can be accessed with `find-hook' at (list NAME OBJECT). 337 | OBJECT is an arbitrary value the hook is associated to." 338 | (let ((hook 339 | (apply #'make-instance hook-type 340 | :handlers handlers 341 | :disabled-handlers disabled-handlers 342 | (if combination 343 | (list :combination combination) 344 | '())))) 345 | (setf (gethash (list name object) %hook-table) 346 | hook) 347 | hook)) 348 | 349 | (defun find-hook (name &optional object) 350 | "Return the global hook with name NAME associated to OBJECT, if provided. 351 | The following examples return different hooks: 352 | - (find-hook 'foo-hook) 353 | - (find-hook 'foo-hook 'bar-class) 354 | - (find-hook 'foo-hook (make-instance 'bar-class))" 355 | (gethash (list name object) %hook-table)) 356 | 357 | (defmethod add-hook ((hook hook) handler &key append) 358 | "Add HANDLER to HOOK. Return HOOK. 359 | Check HANDLER's type according to the `handler-type' slot of HOOK." 360 | (with-simple-restart (skip "Do not add this handler.") 361 | (with-simple-restart (reckless-continue "Add this handler nonetheless.") 362 | (probe-ftype (fn handler) (handler-type hook))) 363 | (add-hook-internal hook handler :append append))) 364 | 365 | (defmacro define-hook-type (name type &optional documentation) 366 | "Define hook class. 367 | Type must be something like: 368 | 369 | (function (string) (values integer t)) 370 | 371 | The `handler-type' of the defined hook class has `:class' allocation 372 | type, so that all hooks of such class have the same `handler-type'." 373 | (let* ((name (string name)) 374 | (hook-class-name (intern (serapeum:concat "HOOK-" name)))) 375 | `(defclass ,hook-class-name (hook) 376 | ((handler-type :initform ',type :allocation :class)) 377 | (:metaclass closer-mop:funcallable-standard-class) 378 | ,@(when documentation 379 | `((:documentation ,documentation)))))) 380 | 381 | ;; TODO: Allow listing all the hooks? 382 | 383 | (define-hook-type void (function ()) 384 | "Empty hook type with no arguments.") 385 | (define-hook-type string->string (function (string) string) 386 | "Hook that takes a string and produces a new one.") 387 | (define-hook-type number->number (function (number) number) 388 | "Hook taking a number and returning a number.") 389 | (define-hook-type any (function (&rest t)) 390 | "Hook accepting any arguments and returning anything.") 391 | 392 | (defmacro on (hook args &body body) 393 | "Attach a handler with ARGS and BODY to the HOOK. 394 | 395 | ARGS can be 396 | - A symbol if there's only one argument to the callback. 397 | - A list of arguments. 398 | - An empty list, if the hook handlers take no argument." 399 | (let ((handler-name (gensym "on-hook-handler")) 400 | (args (alexandria:ensure-list args))) 401 | `(add-hook 402 | ,hook (make-instance 'handler 403 | :fn (lambda ,args 404 | (declare (ignorable ,@args)) 405 | ,@body) 406 | :name (quote ,handler-name))))) 407 | 408 | (defmacro once-on (hook args &body body) 409 | "Attach a handler with ARGS and BODY to the HOOK. 410 | 411 | Remove the handler after it fires the first time. 412 | 413 | See `on'." 414 | (let ((handler-name (gensym "once-on-hook-handler")) 415 | (args (alexandria:ensure-list args))) 416 | (alexandria:once-only (hook) 417 | `(add-hook 418 | ,hook (make-instance 'handler 419 | :fn (lambda ,args 420 | (declare (ignorable ,@args)) 421 | (remove-hook ,hook (quote ,handler-name)) 422 | ,@body) 423 | :name (quote ,handler-name)))))) 424 | 425 | (defstruct promise 426 | (lock (bt:make-lock)) 427 | (condition (bt:make-condition-variable)) 428 | (value nil)) 429 | 430 | (defun fulfill (promise &optional value) 431 | (setf (promise-value promise) value) 432 | (bt:condition-notify (promise-condition promise))) 433 | 434 | (defun force (promise) 435 | (let ((lock (promise-lock promise))) 436 | (bt:with-lock-held (lock) 437 | (bt:condition-wait (promise-condition promise) lock)) 438 | (promise-value promise))) 439 | 440 | (defmacro wait-on (hook args &body body) 441 | "Wait until HOOK is run. 442 | Note that it does not necessarily wait until hook has finished running all 443 | handlers. 444 | Return the BODY return value." 445 | (alexandria:with-gensyms (promise) 446 | (let ((handler-name (gensym "wait-on-handler")) 447 | (args (alexandria:ensure-list args))) 448 | (alexandria:once-only (hook) 449 | `(let ((,promise (make-promise))) 450 | (add-hook 451 | ,hook (make-instance 'handler 452 | :fn (lambda ,args 453 | (declare (ignorable ,@args)) 454 | (remove-hook ,hook (quote ,handler-name)) 455 | (fulfill ,promise (progn ,@body))) 456 | :name (quote ,handler-name))) 457 | (force ,promise)))))) 458 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :nhooks 2 | (:use :common-lisp) 3 | (:import-from :serapeum 4 | #:*hook* 5 | #:add-hook 6 | #:remove-hook 7 | #:run-hooks 8 | #:run-hook 9 | #:run-hook-until-failure 10 | #:run-hook-until-success 11 | #:with-hook-restart) 12 | (:import-from #:alexandria 13 | #:required-argument) 14 | (:export 15 | #:*hook* 16 | #:add-hook 17 | #:remove-hook 18 | #:run-hooks 19 | #:run-hook 20 | #:run-hook-with-args-until-failure 21 | #:run-hook-with-args-until-success 22 | #:with-disable-handler-restart 23 | #:default-combine-hook 24 | #:combine-hook-until-failure 25 | #:combine-hook-until-success 26 | #:combine-composed-hook 27 | #:find-handler 28 | #:disable-hook 29 | #:enable-hook 30 | #:define-hook 31 | #:find-hook 32 | #:define-hook-type 33 | ;; Handler class: 34 | #:handler 35 | #:name 36 | #:fn 37 | #:description 38 | #:place 39 | #:value 40 | ;; Hook class: 41 | #:hook 42 | #:handler-type 43 | #:handlers-alist 44 | #:handlers 45 | #:disabled-handlers 46 | #:combination 47 | ;; Pre-generated types: 48 | #:hook-void 49 | #:hook-string->string 50 | #:hook-number->number 51 | #:hook-any 52 | ;; Short hook helpers 53 | #:on 54 | #:once-on 55 | #:wait-on) 56 | (:documentation "A hook is an instance of the `nhooks:hook' class. 57 | You can define new hook types with the `nhooks:define-hook-type' helper. 58 | Examples: 59 | 60 | (nhooks:define-hook-type string->string (function (string) string)) 61 | 62 | defines the `hook-string->string' hook class. 63 | This is equivalent to using `defclass' and overriding the `nhooks:handler-type' 64 | slot. 65 | 66 | You can then instantiate it: 67 | 68 | (defvar test-hook (make-instance 'nhooks:hook-void)) 69 | 70 | And add handlers to it: 71 | 72 | (nhooks:add-hook test-hook #'my-function) 73 | 74 | To run the hook: 75 | 76 | (nhooks:run-hook test-hook) 77 | 78 | Hook handlers can be automatically derived from named functions when calling 79 | `hooks:add-hook'. If you want to add an anonymous function, you'll have to 80 | instantiate the handler manually: 81 | 82 | (nhooks:add-hook test-hook 83 | (make-instance 'nhooks:handler 84 | :fn (lambda () (format t \"Hello!~%\")) 85 | :name 'my-anonymous-function)) 86 | 87 | You can customize the way handlers are composed by a hook: 88 | 89 | (let ((hook (make-instance 'nhooks:hook-number->number 90 | :handlers (list #'add-1 #'multiply-by-2) 91 | :combination #'nhooks:combine-composed-hook))) 92 | (nhooks:run-hook hook 17)) 93 | ; => 35 94 | 95 | Handlers can be enabled and disabled with `nhooks:enable-hook' and 96 | `nhooks:disable-hook' respectively. 97 | 98 | If the handler is meant to be a setter, the `nhooks:place' and `nhooks:value' 99 | slots can be specified; this helps `nhooks:add-hook' to compare handlers and, in 100 | particular, avoid duplicates in hooks. 101 | 102 | Hooks can be defined globally and attached to arbitrary symbols or objects: 103 | 104 | (nhooks:define-hook 'nhooks:hook-number->number 'foo 105 | :object my-object 106 | 107 | There are also the convenience macros `nhooks:on' and `nhooks:once-on' to attach 108 | a form to a hook and, for once-on, to ensure it's run only once.")) 109 | -------------------------------------------------------------------------------- /readme.org: -------------------------------------------------------------------------------- 1 | #+TITLE: NHooks 2 | 3 | /A hook facility for Common Lisp./ 4 | 5 | This package holds an enhanced implementation of hooks (extension points). 6 | It works similarly to Emacs hooks with crucial improvements: 7 | 8 | - If the compiler allows it (such as SBCL), type-checking is performed 9 | at compile-time and at run-time when adding handlers to a hook. 10 | 11 | - On failure, multiple restarts are offered, such as disabling the offending 12 | handler or simply continuing to the next function. 13 | 14 | - The hook handler execution order and combination can be customized. 15 | 16 | - Anonymous functions (lambdas) can be added to hooks as =handler= objects. 17 | 18 | When inspecting hooks, readable names are thus exposed instead of lambda 19 | blackboxes. 20 | 21 | Handlers are compared through their names (through the mandatory =name= slot). 22 | A hook can not contain multiple handlers with the same name. 23 | 24 | - A special provision is taken for "setters", handlers that are meant to set a 25 | given place to a given values. 26 | 27 | Such =handler= objects can be compared and identified uniquely. 28 | 29 | ** Example 30 | 31 | #+begin_src lisp 32 | (let ((hook (make-instance 'nhooks:hook-number->number 33 | :handlers (list #'add-1 #'multiply-by-2) 34 | :combination #'nhooks:combine-composed-hook))) 35 | (nhooks:run-hook hook 17)) 36 | ;; => 35 37 | #+end_src 38 | 39 | See the [[file:package.lisp][package]] documentation for a usage guide and more examples. 40 | 41 | ** Road-map 42 | 43 | - [ ] Handlers should subclass generic functions and thus be funcallable. 44 | - [ ] Setters could subclass handlers. 45 | 46 | ** History 47 | 48 | This library was originally contributed by the maintainers of the [[https://nyxt-browser.com/][Nyxt]] web 49 | browser to [[https://github.com/ruricolist/serapeum][Serapeum]]. Then it got overhauled and backward compatibility broke, 50 | so a dedicated library was published instead. The Serapeum contrib is 51 | considered deprecated. 52 | 53 | ** Change log 54 | 55 | *** 1.2.2 56 | 57 | - Remove =NASDF= as a dependency. 58 | 59 | *** 1.2.1 60 | 61 | - Major refactoring (turn all the =defmethod=-defined functions into generics). 62 | - =define-hook-type=: New optional =documentation= argument. 63 | 64 | *** 1.2.0 65 | 66 | - Hooks and handlers are now "funcallable", for instance with =(funcall HOOK ARGS)=. 67 | - =find-handler=: New optional =include-disabled= argument. 68 | - Fix bug when appending handler. 69 | - Add =wait-on= helper. 70 | 71 | *** 1.1.1 72 | 73 | - Add package documentation. 74 | - Fix bug on CLISP. 75 | 76 | *** 1.1.0 77 | 78 | - Add =on= and =once-on= helpers. 79 | -------------------------------------------------------------------------------- /tests/package.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:nhooks/tests 2 | (:use #:common-lisp #:lisp-unit2)) 3 | -------------------------------------------------------------------------------- /tests/tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:nhooks/tests) 2 | 3 | (defun void-function () 4 | (format t "Void handler")) 5 | 6 | (defvar test-hook (make-instance 'nhooks:hook-void)) 7 | (nhooks:add-hook test-hook #'void-function) 8 | 9 | (define-test default-hook () 10 | "Run default void hook" 11 | (assert= (length (nhooks:handlers test-hook)) 12 | 1) 13 | (assert-equal (nhooks:run-hook test-hook) 14 | '(nil))) 15 | 16 | (defun add1 (n) 17 | (1+ n)) 18 | 19 | (declaim (ftype (function (number) number) mul2)) 20 | (defun mul2 (n) 21 | (* 2 n)) 22 | 23 | (define-test default-numeric-hook () 24 | "Run default numeric hook" 25 | (assert-equal (nhooks:run-hook 26 | (make-instance 'nhooks:hook-number->number :handlers (list #'add1)) 27 | 17) 28 | '(18))) 29 | 30 | (define-test defualt-with-multiple-handlers () 31 | "Run default numeric hook with multiple handlers" 32 | (assert-equal (nhooks:run-hook 33 | (make-instance 'nhooks:hook-number->number 34 | :handlers (list #'add1 35 | (make-instance 'nhooks:handler 36 | :fn (lambda (n) (* 2 n)) 37 | :name 'mul2))) 38 | 17) 39 | '(18 34))) 40 | 41 | (define-test no-duplicates () 42 | "Don't add duplicate handlers." 43 | (assert-equal (let ((hook (make-instance 'nhooks:hook-number->number :handlers (list #'add1)))) 44 | (nhooks:add-hook hook #'add1) 45 | (nhooks:run-hook hook 17)) 46 | '(18)) 47 | (assert-equal (let ((hook (make-instance 'nhooks:hook-number->number :handlers (list #'add1)))) 48 | (nhooks:add-hook hook (make-instance 'nhooks:handler :fn (lambda (n) (+ 1 n)) :name 'add1)) 49 | (nhooks:run-hook hook 17)) 50 | '(18))) 51 | 52 | (define-test combine-handlers () 53 | "Combine handlers" 54 | (assert= (let ((hook (make-instance 'nhooks:hook-number->number 55 | :handlers (list #'add1 #'mul2) 56 | :combination #'nhooks:combine-composed-hook))) 57 | (nhooks:run-hook hook 17)) 58 | 35) 59 | (assert= (let ((hook (make-instance 'nhooks:hook-number->number 60 | :combination #'nhooks:combine-composed-hook))) 61 | (nhooks:run-hook hook 17)) 62 | 17)) 63 | 64 | (define-test remove-hook () 65 | "Remove handler from hook" 66 | (assert-eq (let* ((handler1 #'add1) 67 | (hook (make-instance 'nhooks:hook-number->number 68 | :handlers (list handler1 69 | (make-instance 'nhooks:handler :fn (lambda (n) (* 3 n)) :name 'mul3))))) 70 | (nhooks:remove-hook hook 'mul3) 71 | (nhooks:remove-hook hook handler1) 72 | (nhooks:run-hook hook 17)) 73 | nil)) 74 | 75 | (define-test disable-hook () 76 | "Disable hook" 77 | (let* ((handler1 #'add1) 78 | (handler2 #'mul2)) 79 | (assert= (let* ((hook (make-instance 'nhooks:hook-number->number 80 | :handlers (list handler1 81 | (make-instance 'nhooks:handler :fn (lambda (n) (* 3 n)) :name 'mul3))))) 82 | (nhooks:disable-hook hook) 83 | (length (nhooks:disabled-handlers hook))) 84 | 2) 85 | (assert-eq (let* ((hook 86 | (make-instance 'nhooks:hook-number->number 87 | :handlers (list (make-instance 'nhooks:handler :fn (lambda (n) (* 3 n)) :name 'mul3))))) 88 | (nhooks:disable-hook hook) 89 | (nhooks:add-hook hook handler1) 90 | (nhooks:disable-hook hook) 91 | (eq (first (nhooks:disabled-handlers hook)) 92 | handler1)) 93 | t) 94 | (assert= (let* ((hook 95 | (make-instance 'nhooks:hook-number->number 96 | :handlers (list handler1 97 | (make-instance 'nhooks:handler :fn (lambda (n) (* 3 n)) :name 'mul3))))) 98 | (nhooks:disable-hook hook) 99 | (nhooks:enable-hook hook) 100 | (length (nhooks:disabled-handlers hook))) 101 | 0) 102 | (assert-equal (let* ((hook 103 | (make-instance 'nhooks:hook-number->number 104 | :handlers (list handler1 handler2)))) 105 | (nhooks:disable-hook hook handler1) 106 | (list (first (nhooks:handlers hook)) 107 | (first (nhooks:disabled-handlers hook)))) 108 | (list handler2 handler1)))) 109 | 110 | (define-test no-unnamed-lambdas () 111 | "Don't accept lambdas without names." 112 | (assert-error 'simple-error 113 | (make-instance 'nhooks:handler :fn (lambda (n) (+ 1 n))))) 114 | 115 | (define-test global-hooks () 116 | "Global hooks" 117 | (assert-true (let ((hook (nhooks:define-hook 'nhooks:hook-number->number 'foo))) 118 | (eq hook (nhooks:find-hook 'foo)))) 119 | (let ((hook (nhooks:define-hook 'nhooks:hook-number->number 'foo))) 120 | (assert-true (eq (nhooks:find-hook 'foo) hook))) 121 | (let ((hook (nhooks:define-hook 'nhooks:hook-number->number 'foo 122 | :object #'mul2))) 123 | (assert-false (eq (nhooks:find-hook 'foo) 124 | hook))) 125 | (let ((hook (nhooks:define-hook 'nhooks:hook-number->number 'foo 126 | :object #'mul2))) 127 | (assert-true (eq (nhooks:find-hook 'foo #'mul2) 128 | hook)))) 129 | 130 | (define-test find-handler () 131 | "Find handler" 132 | (let* ((add-handler #'add1) 133 | (mul-handler #'mul2) 134 | (other-handler #'void-function) 135 | (handlers (list add-handler mul-handler))) 136 | (assert-eq (nhooks:find-handler 'add1 handlers) 137 | add-handler) 138 | (assert-eq (nhooks:find-handler mul-handler handlers) 139 | mul-handler) 140 | (assert-eq (nhooks:find-handler other-handler handlers) 141 | nil))) 142 | 143 | (define-test wait () 144 | "Wait on" 145 | (let* ((x 17) 146 | (side-effect 0) 147 | (hook (make-instance 'nhooks:hook-number->number 148 | :handlers (list #'mul2)))) 149 | (let ((th (bt:make-thread (lambda () 150 | (nhooks:wait-on hook y 151 | (incf side-effect) 152 | (1+ y)))))) 153 | (bt:make-thread (lambda () 154 | (sleep 0.5) 155 | (nhooks:run-hook hook x))) 156 | (assert= (bt:join-thread th) 18) 157 | (assert= side-effect 1) 158 | (nhooks:run-hook hook x) 159 | (assert= side-effect 1)))) 160 | --------------------------------------------------------------------------------