184 lines
6.8 KiB
EmacsLisp
184 lines
6.8 KiB
EmacsLisp
;;; syd-prelude.el -*- lexical-binding: t; -*-
|
|
|
|
(eval-when-compile (require 'cl-lib))
|
|
|
|
(require 'syd-constants)
|
|
|
|
(use-package dash)
|
|
|
|
(require 'dash)
|
|
|
|
(cl-defmacro syd-define-stub
|
|
(name &key (desc "implement me!") interactive)
|
|
(let ((todo (format "%s: TODO: %s" name desc)))
|
|
`(defun ,name (&rest _)
|
|
,@(if interactive (list '(interactive)) nil)
|
|
,todo
|
|
(error ,todo))))
|
|
|
|
;; FIXME: When `arg-list' contains nils, things break.
|
|
(cl-defun syd-parse-rest-and-keys (arg-list)
|
|
"The default behaviour of `cl-defun' makes combining &rest with &keys pretty
|
|
useless. This function will partition ARG-LIST by returning a pair (REST
|
|
. KEYS), where REST is the list of ARGS that belong to no key-value pair, and
|
|
KEYS is an alist of the parsed keywords."
|
|
;; Ugh.
|
|
(let (parsed-rest parsed-keys)
|
|
(cl-loop for (lead lag) on arg-list by (lambda (x) (-drop 2 x))
|
|
do (if (keywordp lead)
|
|
(push (cons lead lag) parsed-keys)
|
|
;; Push in reverse order; we reverse the whole list as a
|
|
;; post-processing step.
|
|
(push lead parsed-rest)
|
|
(when lag
|
|
(push lag parsed-rest))))
|
|
(cons (reverse parsed-rest) parsed-keys)))
|
|
|
|
(cl-defun syd-lift-lambdas (&key with-each with-all forms)
|
|
;; Call the continuation if non-nil. Wraps the return value in a singleton
|
|
;; list for "affine" use with unquote-splicing.
|
|
(-let ((call-cont (lambda (cont arg)
|
|
(if cont
|
|
(list (funcall cont arg))
|
|
nil)))
|
|
names)
|
|
`(progn
|
|
,@(cl-loop
|
|
for form in forms
|
|
appending (cond ((syd-hform-symbol form)
|
|
(let ((name (nth 1 form)))
|
|
(push name names)
|
|
(funcall call-cont with-each name)))
|
|
((syd-hform-defun form)
|
|
(let ((name (nth 1 form)))
|
|
(push name names)
|
|
`(,form
|
|
,@(funcall call-cont with-each name))))
|
|
((syd-hform-lambda form)
|
|
(let ((name (gensym "lifted-lambda")))
|
|
(push name names)
|
|
`((defun ,name (&rest args)
|
|
(,form args))
|
|
,@(funcall call-cont with-each name))))
|
|
(t (error "IDK!"))))
|
|
,@(funcall call-cont with-all names))))
|
|
|
|
(defun syd-hform-symbol (hform)
|
|
(and (listp hform)
|
|
(= 2 (length hform))
|
|
(symbolp (nth 1 hform))
|
|
(memq (nth 0 hform) '(quote function))))
|
|
|
|
(defun syd-hform-defun (hform)
|
|
"If HFORM is a defun form, return the defun's name. Otherwise, return nil"
|
|
(when-let* ((sym (car-safe hform)))
|
|
(and (symbolp sym)
|
|
(eq sym 'defun)
|
|
(nth 1 hform))))
|
|
|
|
(defun syd-hform-lambda (hform)
|
|
"If HFORM is a lambda, return non-nil."
|
|
(when-let* ((sym (car-safe hform)))
|
|
(and (symbolp sym)
|
|
(eq sym 'lambda))))
|
|
|
|
(defmacro comment (&rest _)
|
|
"Ignore each argument, and expand to nil."
|
|
nil)
|
|
|
|
(defmacro with-transient-after (hook-or-function &rest forms)
|
|
(declare (indent defun))
|
|
(let ((hook-name (gensym "transient-hook"))
|
|
(hook-or-function* (gensym "hook-or-function")))
|
|
`(let* ((,hook-or-function* ,hook-or-function))
|
|
(defun ,hook-name (&rest _)
|
|
"Transient hook defined by `with-transient-after'."
|
|
(cond ((functionp ,hook-or-function*)
|
|
(advice-remove ,hook-or-function* #',hook-name))
|
|
((symbolp ,hook-or-function*)
|
|
(remove-hook ,hook-or-function* #',hook-name)))
|
|
,@forms)
|
|
(cond ((functionp ,hook-or-function*)
|
|
(advice-add ,hook-or-function* :before #',hook-name))
|
|
((symbolp ,hook-or-function*)
|
|
;; https://www.gnu.org/software/emacs/manual/html_node/elisp/Setting-Hooks.html#Setting-Hooks-1
|
|
(put ',hook-name 'permanent-local-hook t)
|
|
(add-hook ,hook-or-function* #',hook-name))))))
|
|
|
|
(defun syd-plist-put (plist prop new-val)
|
|
"Immutably update a single property of PLIST. Like `plist-put', but PLIST is
|
|
not mutated; a new plist is returned."
|
|
(cl-loop for (prop* old-val) on plist by #'cddr
|
|
appending (if (eq prop prop*)
|
|
(list prop* new-val)
|
|
(list prop* old-val))))
|
|
|
|
(defmacro syd-add-hook (hooks &rest hforms)
|
|
(declare (indent defun))
|
|
(syd-lift-lambdas
|
|
:forms hforms
|
|
:with-all (lambda (fns)
|
|
(let ((fn* (gensym "fn"))
|
|
(fns* (gensym "fns"))
|
|
(hook* (gensym "hook")))
|
|
`(let ((,fns* (list ,@(--map `(function ,it)
|
|
fns))))
|
|
(dolist (,hook* (ensure-list ,hooks))
|
|
(dolist (,fn* ,fns*)
|
|
(add-hook ,hook* ,fn*))))))))
|
|
|
|
(defmacro syd-silently (&rest body)
|
|
`(error "TODO: syd-silently"))
|
|
|
|
(defmacro syd-quietly (&rest body)
|
|
"Evaluate BODY without generating any output.
|
|
|
|
This silences calls to `message', `load', `write-region' and anything that
|
|
writes to `standard-output'. In interactive sessions this inhibits output to
|
|
the echo-area, but not to *Messages*. Return value is that of BODY's final
|
|
form."
|
|
`(if init-file-debug
|
|
(progn ,@body)
|
|
,(if noninteractive
|
|
`(syd-silently ,@body)
|
|
`(let ((inhibit-message t)
|
|
(save-silently t))
|
|
(prog1 (progn ,@body)
|
|
(message ""))))))
|
|
|
|
(defun syd--parse-defadvice-args (arg-list)
|
|
"Parses the docstring and keywords provided to `syd-defadvice'."
|
|
(let (docstring
|
|
advice)
|
|
(when (stringp (car-safe arg-list))
|
|
(setq docstring (pop arg-list)))
|
|
(while (and (length> arg-list 2)
|
|
(keywordp (car arg-list)))
|
|
(let ((how (pop arg-list))
|
|
(sym (pop arg-list)))
|
|
(push (cons how sym) advice)))
|
|
;; What's left of `arg-list' is the body of the defun.
|
|
(list docstring advice arg-list)))
|
|
|
|
(defmacro syd-defadvice (name params &rest args)
|
|
"Define a function and add it as advice."
|
|
(declare (indent defun))
|
|
(-let (((docstring advice body) (syd--parse-defadvice-args args)))
|
|
`(progn (defun ,name ,params
|
|
,@(-some-> docstring list)
|
|
,@body)
|
|
,@(-map (lambda (arg)
|
|
(-let (((how . sym) arg))
|
|
`(advice-add ,sym ,how #',name)))
|
|
advice))))
|
|
|
|
(syd-defadvice syd-lsp-install-server-a ()
|
|
:override #'lsp-install-server
|
|
(user-error (concat "Ignoring a call to `lsp-install-server'"
|
|
" — tell the caller to use Nix!")))
|
|
|
|
(defun syd-str (sep &rest strs)
|
|
(mapconcat #'identity strs sep))
|
|
|
|
(provide 'syd-prelude)
|