Madeleine Sydney Ślaga
a9f95a1675
All checks were successful
build / build (push) Successful in 2m53s
231 lines
8.6 KiB
EmacsLisp
Executable File
231 lines
8.6 KiB
EmacsLisp
Executable File
;;; -*- lexical-binding: t; -*-
|
|
|
|
(eval-when-compile (require 'cl-lib))
|
|
(require 'syd/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))))
|
|
|
|
(defun syd-emacs-file (&rest components)
|
|
"Construct a file path relative to `user-emacs-directory'."
|
|
(apply #'file-name-concat
|
|
user-emacs-directory components))
|
|
|
|
(defmacro syd-push (place &rest elts)
|
|
"Push ELTS onto PLACE, mutating it."
|
|
`(setq ,place (append (list ,@elts) ,place)))
|
|
|
|
;; (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-remap-mode-to-ts (mode)
|
|
"Given a symbol MODE of form *-mode, remap *-mode to *-ts-mode via
|
|
`major-mode-remap-alist'."
|
|
(let ((s (symbol-name mode)))
|
|
(if (string-match (rx bol (group (* any)) "-mode" eol)
|
|
s)
|
|
(add-to-list
|
|
'major-mode-remap-alist
|
|
(cons mode (intern (concat (match-string 1 s) "-ts-mode"))))
|
|
(error "Symbol `%c' is not a mode." mode))))
|
|
|
|
(defun syd--insert-file-name-annotation (x)
|
|
(concat
|
|
" "
|
|
(propertize " " 'display `(space :align-to (- right ,(+ 1 (length x)))))
|
|
x))
|
|
|
|
(defun syd-insert-file-name ()
|
|
(interactive)
|
|
(let* ((path (read-file-name "Path: " nil nil 'confirm))
|
|
(proj-root (project-root (project-current)))
|
|
(alts
|
|
`((,(file-relative-name path proj-root) . "Project-relative")
|
|
(,(file-relative-name path default-directory) . "File-relative")
|
|
(,path . "Absolute")
|
|
("... (choose a dir)")))
|
|
(choice
|
|
(completing-read
|
|
"Variant: "
|
|
(lambda (s p flag)
|
|
(pcase flag
|
|
('metadata
|
|
`(metadata
|
|
(annotation-function
|
|
. ,(lambda (s)
|
|
(when-let* ((desc (cdr (assoc s alts))))
|
|
(syd--insert-file-name-annotation
|
|
desc))))))
|
|
(_ (all-completions s (mapcar #'car alts) p)))))))
|
|
(if (equal choice "... (choose a root)")
|
|
(insert (file-relative-name
|
|
path (read-file-name "Relative to: " nil nil
|
|
'confirm)))
|
|
(insert choice))))
|
|
|
|
(provide 'syd/prelude)
|