From: Andreas Gerler Date: Thu, 11 May 2023 16:13:18 +0000 (+0200) Subject: add noflet X-Git-Url: http://git.bundesbrandschatzamt.de/?a=commitdiff_plain;h=08b57bc39a88a146d913b66df1869c2ab0230115;p=emacsconfig.git add noflet Signed-off-by: Andreas Gerler --- diff --git a/elpa/noflet-20141102.1454/noflet-autoloads.el b/elpa/noflet-20141102.1454/noflet-autoloads.el new file mode 100644 index 00000000..dd5df60d --- /dev/null +++ b/elpa/noflet-20141102.1454/noflet-autoloads.el @@ -0,0 +1,22 @@ +;;; noflet-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*- +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "noflet" "noflet.el" (0 0 0 0)) +;;; Generated autoloads from noflet.el + +(register-definition-prefixes "noflet" '("letn" "ntake-all")) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; noflet-autoloads.el ends here diff --git a/elpa/noflet-20141102.1454/noflet-pkg.el b/elpa/noflet-20141102.1454/noflet-pkg.el new file mode 100644 index 00000000..2b8b66f6 --- /dev/null +++ b/elpa/noflet-20141102.1454/noflet-pkg.el @@ -0,0 +1,2 @@ +;;; Generated package description from noflet.el -*- no-byte-compile: t -*- +(define-package "noflet" "20141102.1454" "locally override functions" 'nil :commit "7ae84dc3257637af7334101456dafe1759c6b68a" :authors '(("Nic Ferrier" . "nferrier@ferrier.me.uk")) :maintainer '("Nic Ferrier" . "nferrier@ferrier.me.uk") :keywords '("lisp") :url "https://github.com/nicferrier/emacs-noflet") diff --git a/elpa/noflet-20141102.1454/noflet.el b/elpa/noflet-20141102.1454/noflet.el new file mode 100644 index 00000000..a5f95e3f --- /dev/null +++ b/elpa/noflet-20141102.1454/noflet.el @@ -0,0 +1,178 @@ +;;; noflet.el --- locally override functions + +;; Copyright (C) 2013 Nic Ferrier + +;; Author: Nic Ferrier +;; Keywords: lisp +;; Package-Version: 20141102.1454 +;; Package-Commit: 7ae84dc3257637af7334101456dafe1759c6b68a +;; Version: 0.0.15 +;; Url: https://github.com/nicferrier/emacs-noflet + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This let's you locally override functions, in the manner of `flet', +;; but with access to the original function through the symbol: +;; `this-fn'. + +;;; Code: + +(eval-when-compile (require 'cl)) +(if (version< emacs-version "24.4.1") + (load-library "cl-indent") + (require 'cl-indent)) + +(defun noflet|base () + "A base function." + :noflet) + +(defun noflet|expand (bindings &rest forms) + "Expand BINDINGS and evaluate FORMS. + +Used by `noflet' to expand it's contents. + +Example: + + (noflet|expand + '((find-file-noselect (file-name) + (if t + (this-fn \"/tmp/mytest\") + (this-fn file-name))) + (expand-file-name (file-name &optional thing) + (if t + (concat \"/tmp/\" file-name) + (funcall this-fn file-name thing)))) + '(progn (expand-file-name \"/home/nferrier/thing\"))) + +It should not be necessary ever to call this. Hence the exotic +name." + (let* + ((fsets + (cl-loop + for i in bindings + collect + (cl-destructuring-bind (name args &rest body) i + (let ((saved-func-namev (make-symbol "saved-func-name"))) + (let ((saved-func-namev + (intern (format "saved-func-%s" + (symbol-name name))))) + `(fset (quote ,name) + (cl-function + (lambda ,args + (let ((this-fn ,saved-func-namev)) + ,@body))))))))) + (fresets + (cl-loop + for i in bindings + collect + (cl-destructuring-bind (name args &rest body) i + (let ((saved-func-namev (make-symbol "saved-func-name"))) + (let ((saved-func-namev + (intern (format "saved-func-%s" + (symbol-name name))))) + `(if + (eq (symbol-function (quote noflet|base)) + ,saved-func-namev) + (fmakunbound (quote ,name)) + (fset (quote ,name) ,saved-func-namev))))))) + (lets + (cl-loop + for i in bindings + collect + (cl-destructuring-bind (name args &rest body) i + (let ((saved-func-namev (make-symbol "saved-func-name"))) + (let ((saved-func-namev + (intern (format "saved-func-%s" + (symbol-name name))))) + `(,saved-func-namev + (condition-case err + (symbol-function (quote ,name)) + (void-function + (symbol-function (quote noflet|base))))))))))) + `(let ,lets + (unwind-protect + (progn + (progn ,@fsets) + ,@forms) + (progn ,@fresets))))) + +(defun noflet-indent-func (pos &rest state) + "Deliver sensible indenting for flet like functions." + ;; (message "pos: %s state: %s" pos state) + (save-excursion + (goto-char (elt (car state) 1)) + (+ 2 + (- (point) + (line-beginning-position))))) + +(defmacro noflet (bindings &rest body) + "Make local function BINDINGS allowing access to the original. + +Each of the BINDINGS is done like in `flet': + + (noflet + ((expand-file-name (file-name &optional default-dir) + (concat defaulr-dir file-name))) + (expand-file-name \"~/test\")) + +In each of the BINDINGS the original function is accessible with +the name `this-fn': + + (noflet + ((expand-file-name (file-name &optional default-dir) + (if (string-match-p \"/fake.*\" file-name) + (concat default-dir file-name) + (funcall this-fn file-name default-dir)))) + (expand-file-name \"~/test\")) + +This is great for overriding in testing and such like. + +If new bindings are introduced the binding is discarded upon +exit. Even with new bindings there is still a `this-fn'. It +points to `noflet|base' for all new bindings." + (declare (debug ((&rest (cl-defun)) cl-declarations body)) + (indent noflet-indent-func)) + (apply 'noflet|expand bindings body)) + +(defmacro nolexflet (bindings &rest body) + "Lexical version. + +This only exists as an alias for `cl-flet' because Emacs +maintainers refuse to add the correct indentation spec to +`cl-flet'." + (declare (debug ((&rest (cl-defun)) cl-declarations body)) + (indent noflet-indent-func)) + `(cl-flet ,bindings ,@body)) + +(defmacro* letn (tag bindings &rest body) + (declare (debug (sexp sexp &rest form)) + (indent 2)) + `(cl-labels ((,tag ,(-map 'car bindings) ,@body)) + (,tag ,@(-map 'cadr bindings)))) + +(defun ntake-all (f source) + (letn take-all ((result nil) + (src source)) + (if src + (let ((l (-take-while f src))) + (take-all (cons l result) + (nthcdr (+ 1 (length l)) src))) + result))) + + +(provide 'noflet) + +;;; noflet.el ends here