From 8c7871fec56b6c464bd06ba114225d7971c4699a Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Tue, 15 Nov 2022 19:51:52 -0600 Subject: meh --- .gitignore | 1 + init.el | 347 ++++++++++++++++++++++++++++++++++++++++++++++++++------- lisp/+emacs.el | 6 +- lisp/acdw.el | 80 +++++++------ lisp/dawn.el | 84 ++++++++++++++ lisp/yoke.el | 88 ++++++++++++--- 6 files changed, 511 insertions(+), 95 deletions(-) create mode 100644 lisp/dawn.el diff --git a/.gitignore b/.gitignore index a61fa52..a40481b 100644 --- a/.gitignore +++ b/.gitignore @@ -26,3 +26,4 @@ lisp/*-autoloads.el # put random stuff in here scratch.el +jabber-avatar-cache/ \ No newline at end of file diff --git a/init.el b/init.el index bf52e4f..c73e169 100644 --- a/init.el +++ b/init.el @@ -68,9 +68,29 @@ "M-o" #'other-window|switch-buffer "C-M-;" #'+lisp-comment-or-uncomment-sexp "C-x 5 z" #'suspend-frame - "M-@" #'dictionary-search) + "M-@" #'dictionary-search + "C-x f" #'find-file) (define-key* text-mode-map - "C-M-k" #'kill-paragraph) + "C-M-k" #'kill-paragraph + "C-o" (defun open-paragraph (&optional arg) + "Open a paragraph after paragraph at point. +A paragraph is defined as continguous non-empty lines of text +surrounded by empty lines, so opening a paragraph means to make +three blank lines, then place the point on the second one. + +Called with prefix ARG, open a paragraph before point." + ;; TODO: Take an integer as ARG, allowing for skipping paragraphs up and down. + (interactive "*P") + ;; Go to next blank line. This /isn't/ `end-of-paragraph-text' because + ;; that's weird with org, and I'm guessing other modes too. + (unless (looking-at "^$") (forward-line (if arg -1 +1))) + (while (and (not (looking-at "^$")) + (= 0 (forward-line (if arg -1 +1))))) + (newline) + (when arg (newline) (forward-line -2)) + (delete-blank-lines) + (newline 2) + (previous-line))) ;; Hooks (add-hook 'after-save-hook #'executable-make-buffer-file-executable-if-script-p) @@ -86,8 +106,7 @@ "Don't close quits on `keyboard-escape-quit'." (let ((buffer-quit-function #'ignore)) (apply fn r))) - ;; Themes - (load-theme 'modus-operandi) + ;; Faces (set-face-attribute 'default nil :family "Comic Code" :height 100) (set-face-attribute 'bold nil :family "Comic Code" :weight 'bold) (set-face-attribute 'variable-pitch nil :family "Comic Code") @@ -104,6 +123,22 @@ (eval-after init (+custom-load-some-customizations :noerror))) +(yoke modus-themes + (setf modus-themes-bold-constructs t + modus-themes-italic-constructs t + modus-themes-headings '((1 monochrome bold italic) + (2 monochrome bold) + (3 monochrom italic) + (t monochrome))) + (cond ((require 'dawn nil :noerrer) + (add-hook* '+custom-after-load-hook + (defun dawn@custom () + (load-theme 'modus-operandi :noconfirm :noenable) + (load-theme 'modus-vivendi :noconfirm :noenable) + (dawn-schedule #'modus-themes-load-operandi + #'modus-themes-load-vivendi)))) + (:else (load-theme 'modus-operandi)))) + (yoke time (setf display-time-mail-function (defun +notmuch-new-mail-p () @@ -115,6 +150,8 @@ :count)) display-time-use-mail-icon t read-mail-command #'+notmuch-goto + display-time-format " %a %-e, %H:%M" + ;; `display-time-format' makes these unnecessary, but I'll keep em display-time-24hr-format t display-time-day-and-date t display-time-default-load-average nil) @@ -229,7 +266,8 @@ (setq-local-hook dired-mode-hook truncate-lines t) (define-key* (current-global-map) - "C-x C-j" #'dired-jump) + "C-x C-j" #'dired-jump + [remap list-directory] #'dired) (eval-after dired (define-key* dired-mode-map "" #'dired-up-directory @@ -262,7 +300,7 @@ (advice-add #'register-preview :override #'consult-register-window) (define-key* (current-global-map) ;; Etc - "C-x m" #'consult-mode-command + "M-S-x" #'consult-mode-command ;; C-c bindings (mode-specific-map) "C-c h" #'consult-history "C-c b" #'consult-bookmark @@ -351,25 +389,17 @@ (marginalia-mode)) (yoke (wgrep "https://github.com/mhayashi1120/Emacs-wgrep") - (require 'wgrep)) - -;; (yoke (slime "https://github.com/slime/slime") -;; ;; r7rs-swank -;; (let ((r7rsloc (yoke-git "https://github.com/ecraven/r7rs-swank"))) -;; (cond -;; ((executable-find "chibi-scheme") -;; (defun chibi-scheme-start-swank (file encoding) -;; (format "%S\n\n" `(start-swank ,file))) -;; (setq slime-lisp-implementations -;; (cons `(chibi-scheme -;; ("chibi-scheme" ,(format "-A%s" r7rsloc) -;; "-m" "(chibi-swank)") -;; :init chibi-scheme-start-swank) -;; (bound-and-true-p slime-lisp-implementations))) -;; ;; (add-hook* 'scheme-mode-hook #'slime-mode) -;; (setf slime-completion-at-point-functions -;; (delq 'slime-c-p-c-completion-at-point -;; slime-completion-at-point-functions)))))) + (require 'wgrep) + (define-key* grep-mode-map + "C-x C-q" #'wgrep-change-to-wgrep-mode)) + +(yoke (slime "https://github.com/slime/slime") + :when (executable-find "sbcl") + (setf inferior-lisp-program (executable-find "sbcl")) + (eval-after slime + (setf slime-completion-at-point-functions + (delq 'slime-c-p-c-completion-at-point + slime-completion-at-point-functions)))) (yoke (puni "https://github.com/amaikinono/puni") (define-key* puni-mode-map @@ -537,7 +567,21 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." "RET" #'+org-return-dwim "S-" #'+org-table-copy-down|+org-return "C-c C-o" #'+org-open-at-point-dwim) - (org-clock-persistence-insinuate))) + (org-clock-persistence-insinuate)) + (eval-after ol ; org-link + (defmacro define-org-link-type (type args &rest body) + "Define an org link TYPE with ARGS that does something. + If BODY is blank, message the user about the link." + (declare (indent 2) (doc-string 3) (debug (sexp sexp def-body))) + (let ((fn (intern (format "org-%s-open" type))) + (body (or body `((message ,(format "%s: %%S" type) ,(car args))))) + (type-string (format "%s" type))) + `(prog1 + (defun ,fn ,args + ,@body) + (org-link-set-parameters ,type-string :follow #',fn)))) + (define-org-link-type sms (number _)) + (define-org-link-type tel (number _)))) (yoke org-agenda nil (setq org-agenda-skip-deadline-if-done t @@ -556,7 +600,18 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." org-agenda-include-deadlines t org-deadline-warning-days 0 org-agenda-show-future-repeats 'next - org-agenda-window-setup 'current-window) + org-agenda-window-setup 'current-window + org-agenda-file-skip-regexp "sync-conflict") + (defcustom org-agenda-file-skip-regexp nil + "Files matching this regexp are removed from `org-agenda-files'." + :group 'org-agenda) + (define-advice org-agenda-files (:filter-return (files) skip-regexp) + (when org-agenda-file-skip-regexp + (setq files (seq-remove (lambda (file) + (string-match-p org-agenda-file-skip-regexp + file)) + files))) + files) (setq-local-hook org-agenda-mode-hook truncate-lines t electric-pair-pairs (append electric-pair-pairs @@ -574,17 +629,17 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." '+org-capture)) (yoke ox ; org-export - (eval-after org (require 'ox)) - (eval-after ox - (require* '+ox '(ox-md nil t)) - (+org-export-pre-hooks-insinuate)) - (setq org-export-coding-system 'utf-8-unix - org-export-headline-levels 8 - org-export-with-drawers nil - org-export-with-section-numbers nil - org-export-with-smart-quotes t - org-export-with-sub-superscripts t - org-export-with-toc nil)) + (eval-after org (require 'ox)) + (eval-after ox + (require* '+ox '(ox-md nil t)) + (+org-export-pre-hooks-insinuate)) + (setq org-export-coding-system 'utf-8-unix + org-export-headline-levels 8 + org-export-with-drawers nil + org-export-with-section-numbers nil + org-export-with-smart-quotes t + org-export-with-sub-superscripts t + org-export-with-toc nil)) (yoke (electric-cursor "https://codeberg.org/acdw/electric-cursor.el") (setq electric-cursor-alist '((overwrite-mode . hbar) @@ -683,6 +738,7 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." "@" #'dictionary-search))) (yoke (anzu "https://github.com/emacsorphanage/anzu") + (require 'anzu) (global-anzu-mode) (define-key* (current-global-map) [remap query-replace] #'anzu-query-replace-regexp @@ -693,9 +749,11 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." (defun anzu-qr@window (fn &rest r) "ADVICE to query-replace from the beginning of the window." (let ((scroll-margin 0)) - (save-excursion - (goto-char (window-start)) - (apply fn r)))) + (cond ((region-active-p) + (apply fn r)) + (:else (save-excursion + (goto-char (window-start)) + (apply fn r)))))) (advice-add 'anzu-query-replace-regexp :around #'anzu-qr@window) (advice-add 'anzu-query-replace :around #'anzu-qr@window)) @@ -704,6 +762,10 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." (yoke (0x0 "https://gitlab.com/willvaughn/emacs-0x0") (setf 0x0-default-server 'ttm) + (define-advice 0x0-shorten-uri (:around (fn server uri) use-0x0) + (interactive (list (cdr (assq 'envs 0x0-servers)) + (read-string "URI: "))) + (funcall fn server uri)) (eval-after embark (define-key* embark-region-map "U" #'0x0-dwim))) @@ -759,8 +821,24 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." :when (executable-find "keychain") (keychain-refresh-environment)) +(yoke (exec-path-from-shell "https://github.com/purcell/exec-path-from-shell") + :when (eq system-type 'gnu/linux) + (require 'exec-path-from-shell) + (dolist (var '("SSH_AUTH_SOCK" + "SSH_AGENT_PID" + "GPG_AGENT_INFO" + "LANG" + "LC_CTYPE" + "XDG_CONFIG_HOME" + "XDG_CONFIG_DIRS" + "XDG_DATA_HOME" + "XDG_DATA_DIRS" + "XDG_CACHE_HOME")) + (add-to-list 'exec-path-from-shell-variables var)) + (exec-path-from-shell-initialize)) + (yoke (sophomore "https://codeberg.org/acdw/sophomore.el") - (sophomore-enable #'narrow-to-region) + (sophomore-enable-all) (sophomore-disable #'view-hello-file #'describe-gnu-project) (sophomore-disable-with 'confirm #'save-buffers-kill-terminal)) @@ -844,12 +922,20 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." message-sendmail-envelope-from 'header message-envelope-from 'header) ;; Extras + (define-advice mm-save-part-to-file (:before (_handle file) create-directory) + (let ((directory (file-name-directory file))) + (when (yes-or-no-p (format "Directory %s doesn't exist. Create?" directory)) + (make-directory directory :parents)))) (eval-after notmuch (require '+notmuch) (load notmuch-init-file :noerror) (add-hook 'message-setup-hook #'+message-signature-setup) (add-hook 'message-send-hook #'+send-mail-dispatch) (advice-add 'notmuch-tag :filter-args #'+notmuch-correct-tags) + (advice-add 'notmuch-bury-or-kill-this-buffer :after + (defun +display-time@notmuch (&rest _) + ;; (display-time-event-handler) + (display-time-update))) (setf notmuch-saved-searches (list (list :name "inbox+unread" :query (+notmuch-query-concat @@ -906,6 +992,152 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." (sesman "https://github.com/vspinu/sesman")) :when (executable-find "clojure")) +(yoke (web-mode "https://github.com/fxbois/web-mode") + (setf (alist-get (rx "." (or "htm" "html" "phtml" "tpl.php" + "asp" "gsp" "jsp" "ascx" "aspx" + "erb" "mustache" "djhtml") + eos) + auto-mode-alist nil nil #'string=) + 'web-mode)) + +(yoke (chicken-geiser "https://gitlab.com/emacs-geiser/chicken") + :depends ((geiser "https://gitlab.com/emacs-geiser/geiser" + :load "elisp")) + :when (executable-find "csi") + :pre ((autoload 'geiser-activate-implementation "geiser-impl")) + (autoload 'geiser "geiser" nil :interactive) + (add-hook 'scheme-mode-hook 'geiser-mode)) + +(yoke (zoom-frm "https://github.com/emacsmirror/zoom-frm") + :depends ((frame-cmds "https://github.com/emacsmirror/frame-cmds") + (frame-fns "https://github.com/emacsmirror/frame-fns")) + (define-key* (current-global-map) + "M-+" #'zoom-frm-in + "M-_" #'zoom-frm-out)) + +(yoke (jabber "https://codeberg.org/acdw/emacs-jabber") + :depends ((srv "https://github.com/legoscia/srv.el") + (fsm "https://elpa.gnu.org/packages/fsm-0.2.1.el" :type 'http)) + (setf jabber-account-list '(("acdw@hmm.st")) + jabber-auto-reconnect t + jabber-chat-buffer-format "xmpp:%n" + jabber-browse-buffer-format "xmpp-browse:%n" + jabber-groupchat-buffer-format "xmpp-muc:%n" + jabber-muc-private-buffer-format "xmpp-muc-private:%n" + jabber-groupchat-prompt-format "%>10n │ " + jabber-chat-local-prompt-format "%>10n │ " + jabber-chat-system-prompt-format " * * * * * *" + jabber-chat-foreign-prompt-format "%>10n │ " + jabber-muc-private-foreign-prompt-format "%g/%n " + jabber-last-read-marker "----------------------------------------" + jabber-muc-header-line-format '("" jabber-muc-topic) + jabber-muc-decorate-presence-patterns + '(("\\( enters the room ([^)]+)\\| has left the chatroom\\)$") + ("." . jabber-muc-presence-dim)) + jabber-activity-make-strings + #'jabber-activity-make-strings-shorten + ;; (defun +jabber-activity-make-strings (jids) + ;; (mapcar (lambda (jid) + ;; (cons jid + ;; (let ((s (jabber-activity-make-string-default jid))) + ;; (cond + ;; ((string-match-p "%" s) + ;; (replace-regexp-in-string "%.*" "" s)) + ;; (:else s))))) + ;; jids)) + jabber-rare-time-format " - - - - - - %H:00 %F") + (defun +electric-pair-disable-local-mode () + (electric-pair-local-mode -1)) + (add-hook* '(jabber-chat-mode-hook + jabber-browse-mode-hook + jabber-roster-mode-hook + jabber-console-mode-hook) + #'visual-fill-column-mode + #'+electric-pair-disable-local-mode) + (defun +jabber-fix-keybinds-dammit () + "Jabber autoloads keybinds which is really annoying." + (define-key* (current-global-map) + "C-x C-j" #'dired-jump + "C-c j" jabber-global-keymap + "C-c C-SPC" #'jabber-activity-switch-to)) + (eval-after init (+jabber-fix-keybinds-dammit)) + (eval-after jabber + (require 'jabber-httpupload nil :noerror) + (add-hook 'jabber-post-connect-hooks #'jabber-enable-carbons) + (remove-hook 'jabber-alert-muc-hooks 'jabber-muc-echo) + (remove-hook 'jabber-alert-presence-hooks 'jabber-presence-echo) + (add-hook 'jabber-alert-muc-hooks + (defun jabber@highlight-acdw (&optional _nick _group buf _text _title) + (when buf + (with-current-buffer buf + (let ((regexp (rx word-boundary + "acdw" ; maybe get from the config? + word-boundary))) + (hi-lock-unface-buffer regexp) + (highlight-regexp regexp 'hi-blue)))))) + (add-hook 'window-configuration-change-hook #'jabber-chat-update-focus) + (+jabber-fix-keybinds-dammit)) + ;; (add-hook* 'jabber-activity-mode-hook + ;; (defun +jabber-activity-mode@move-to-end-of-mode-line () + ;; (setf global-mode-string + ;; (append (delete '(t jabber-activity-mode-string) + ;; global-mode-string) + ;; '((t jabber-activity-mode-string)))))) + (setq-local-hook jabber-chat-mode-hook + wrap-prefix (format "%10s " " ") + mode-line-buffer-identification + (pcase (buffer-name) + ((rx "%") ; biboumi irc channel + ;; xmpp-muc:#scheme%irc.libera.chat@irc.hmm.st + (propertized-buffer-identification + (replace-regexp-in-string "xmpp-muc:\\([^%]*\\)%\\([^@]*\\)@.*" + "\\1@\\2" + (buffer-name)))) + (_ ; xmpp channel + (propertized-buffer-identification "%12b")))) + (defun jabber-chat@after-modus-themes-load () + (modus-themes-with-colors + (custom-set-faces + `(jabber-chat-prompt-foreign ((t :foreground unspecified + :inherit modus-themes-bold)) + :now) + `(jabber-chat-prompt-local ((t :foreground unspecified + :inherit modus-themes-bold)) + :now) + `(jabber-chat-prompt-system ((t :foreground unspecified + :inherit modus-themes-bold)) + :now) + `(jabber-activity-face ((t :slant italic))) + `(jabber-activity-personal-face ((t :slant italic :weight bold))) + `(jabber-rare-time-face ((t :inherit font-lock-comment-face))))) + (setq jabber-muc-nick-value + (pcase (frame--current-backround-mode (selected-frame)) + ('light 0.5) + ('dark 1.0)))) + (eval-after modus-themes + (add-hook 'modus-themes-after-load-theme-hook + #'jabber-chat@after-modus-themes-load)) + (when (or (custom-theme-enabled-p 'modus-operandi) + (custom-theme-enabled-p 'modus-vivendi)) + (jabber-chat@after-modus-themes-load)) + (eval-after (consult jabber) + ;; Jabber.el chat buffers source for `consult-buffer' + (defvar jabber-chat-buffer-source + `( :name "Jabber" + :hidden nil + :narrow ?j + :category buffer + :state ,#'consult--buffer-state + :items ,(lambda () + (mapcar #'buffer-name + (seq-filter (lambda (buf) + (with-current-buffer buf + (eq major-mode 'jabber-chat-mode))) + (buffer-list)))))) + (add-to-list 'consult-buffer-sources 'jabber-chat-buffer-source :append) + ;; Also hide xmpp buffers from regular buffer list + (add-to-list 'consult-buffer-filter "\\`xmpp" nil #'string-equal))) + (yoke (link-hint "https://github.com/noctuid/link-hint.el/") :depends ((avy "https://github.com/abo-abo/avy")) (require '+link-hint) @@ -921,6 +1153,21 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." "M-w" #'link-hint-copy-link "w" #'link-hint-copy-link "M-c" #'+link-hint-open-chrome "c" #'+link-hint-open-chrome)) +(yoke (elpher "git://thelambdalab.xyz/elpher.git") + (eval-after elpher + (define-key* elpher-mode-map + "l" #'elpher-back))) + +(yoke (epithet "https://github.com/oantolin/epithet") + (add-hook* '(Info-selection-hook + help-mode-hook + occur-mode-hook + shell-mode-hook) + #'epithet-rename-buffer) + (cond ((boundp 'eww-auto-rename-buffer) + (setf eww-auto-rename-buffer 'title)) + (:else (add-hook 'eww-after-render-hook #'epithet-rename-buffer)))) + (yoke browse-url (require '+browse-url) (setf browse-url-browser-function #'eww-browse-url @@ -994,3 +1241,19 @@ CAPES defaults to `+capes'. CAPF will be made un-exclusive." (define-key* eww-mode-map "&" #'+eww-browse-with-external-browser)) +(yoke tab-bar + (setf tab-bar-show t + global-mode-string + '((jabber-activity-mode jabber-activity-mode-string) + " ⋅" + display-time-string + "|")) + (add-to-list 'tab-bar-format 'tab-bar-format-align-right :append) + (add-to-list 'tab-bar-format 'tab-bar-format-global :append) + (tab-bar-mode)) + +(yoke (pdf-tools "https://github.com/vedang/pdf-tools" + :load "lisp") + :depends ((tablist "https://github.com/politza/tablist/")) + :when (executable-find "epdfinfo") ; installed from Debian repos + (pdf-tools-install)) diff --git a/lisp/+emacs.el b/lisp/+emacs.el index 8817c19..870e4e2 100644 --- a/lisp/+emacs.el +++ b/lisp/+emacs.el @@ -108,12 +108,10 @@ Do this only if the buffer is not visiting a file." regexp-search-ring-max 200 save-interprogram-paste-before-kill t save-some-buffers-default-predicate #'+save-some-buffers-p - scroll-conservatively 101 - scroll-down-aggressively 0.01 - scroll-margin 2 + scroll-conservatively 25 + scroll-margin 0 scroll-preserve-screen-position 1 scroll-step 1 - scroll-up-aggressively 0.01 search-ring-max 200 search-ring-max 200 sentence-end-double-space t diff --git a/lisp/acdw.el b/lisp/acdw.el index 6e298b2..75e1755 100644 --- a/lisp/acdw.el +++ b/lisp/acdw.el @@ -1,7 +1,5 @@ ;;; acdw.el -- bits and bobs -*- lexical-binding: t; -*- ;; by C. Duckworth -(provide 'acdw) - (require 'cl-lib) ;;; Define both a directory and a function expanding to a file in that directory @@ -30,7 +28,6 @@ the filesystem, unless INHIBIT-MKDIR is non-nil." ;;; Evaluating things after other things - (defun eval-after-init (fn) "Evaluate FN after inititation, or now if Emacs is initialized. FN is called with no arguments." @@ -78,12 +75,12 @@ Convenience wrapper around `define-key'." (unless (fboundp 'ensure-list) ;; Just in case we're using an old version of Emacs. (defun ensure-list (object) - "Return OBJECT as a list. + "Return OBJECT as a list. If OBJECT is already a list, return OBJECT itself. If it's not a list, return a one-element list containing OBJECT." - (if (listp object) - object - (list object)))) + (if (listp object) + object + (list object)))) (defun add-to-list* (lists &rest things) "Add THINGS to LISTS. @@ -130,8 +127,8 @@ without any separator." Each feature of FEATURES can also be a list of the arguments to pass to `require', which see." (condition-case e - (dolist (feature features) - (apply #'require (ensure-list feature))) + (dolist (feature features) + (apply #'require (ensure-list feature))) (:success (mapcar (lambda (f) (car (ensure-list f))) features)) (t (signal (car e) (cdr e))))) @@ -153,22 +150,33 @@ pass to `require', which see." (add-hook 'before-save-hook #',internal-name nil :local)) (add-hook ',hook #',external-name)))) -(defmacro setq-local-hook (hook &rest args) - "Run `setq-local' on ARGS when running HOOK." +(defmacro setq-local-hook (hooks &rest args) + "Run `setq-local' on ARGS when running HOOKs." + ;; FIXME: this is pretty messy, i think... + ;; The settings should be stored in an alist so that they can be deduplicated (declare (indent 1)) - (let ((fn (intern (format "%s-setq-local" hook)))) - (when (and (fboundp fn) - (functionp fn)) - (setf args (append (function-get fn 'setq-local-hook-settings) args))) - (unless (and (< 0 (length args)) - (zerop (mod (length args) 2))) - (user-error "Wrong number of arguments: %S" (length args))) - `(progn - (defun ,fn () - ,(format "Set local variables after `%s'." hook) - (setq-local ,@args)) - (function-put ',fn 'setq-local-hook-settings ',args) - (add-hook ',hook #',fn)))) + `(progn + ,@(cl-loop for hook in (ensure-list hooks) + collect + (let ((fn (intern (format "%s-setq-local" hook)))) + (when (and (fboundp fn) + (functionp fn)) + (setf args (append (function-get fn 'setq-local-hook-settings) args))) + (unless (and (< 0 (length args)) + (zerop (mod (length args) 2))) + (user-error "Wrong number of arguments: %S" (length args))) + `(progn + (defun ,fn () + ,(format "Set local variables after `%s'." hook) + (setq-local ,@args)) + (function-put ',fn 'setq-local-hook-settings ',args) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (when (derived-mode-p + ',(intern (replace-regexp-in-string + "-hook" "" (format "%s" hook)))) + (,fn)))) + (add-hook ',hook #',fn)))))) (defmacro with-message (message &rest body) "Execute BODY, with MESSAGE. @@ -182,6 +190,13 @@ If body executes without errors, MESSAGE...Done will be displayed." (:success (message "%s...done" ,msg)) (t (signal (car e) (cdr e))))))) +(defmacro either (&rest clauses) + "Return the first of CLAUSES that returns non-nil." + (let* ((this (gensym "either"))) + (unless (null clauses) + `(let* ((,this ,(car clauses))) + (if ,this ,this (either ,@(cdr clauses))))))) + ;; https://emacs.stackexchange.com/a/39324/37239 ;; XXX: This shit don't work rn (defun ignore-invisible-overlays (fn) @@ -189,13 +204,13 @@ If body executes without errors, MESSAGE...Done will be displayed." FN should return a point." (let ((overlay nil) (point nil)) - (setq point (and (funcall fn) (point))) - (setq overlay (car (overlays-at (point)))) - (while (and overlay (member 'invisible (overlay-properties overlay))) - (goto-char (overlay-end overlay)) - (setq point (and (funcall fn) (point))) - (setq overlay (car (overlays-at (point))))) - point)) + (setq point (and (funcall fn) (point))) + (setq overlay (car (overlays-at (point)))) + (while (and overlay (member 'invisible (overlay-properties overlay))) + (goto-char (overlay-end overlay)) + (setq point (and (funcall fn) (point))) + (setq overlay (car (overlays-at (point))))) + point)) ;;; Extras ;; Trying to avoid a whole install of crux ... @@ -217,3 +232,6 @@ When called with prefix ARG, unconditionally switch buffer." (if (or arg (one-window-p)) (switch-to-buffer (other-buffer) nil t) (other-window 1))) + +(provide 'acdw) +;;; acdw.el ends here diff --git a/lisp/dawn.el b/lisp/dawn.el new file mode 100644 index 0000000..806c422 --- /dev/null +++ b/lisp/dawn.el @@ -0,0 +1,84 @@ +;;; dawn.el --- Do things at dawn (and dusk) -*- lexical-binding: t; -*- + +;;; Commentary: + +;; There is also circadian.el, but it doesn't quite work for me. +;; This code comes mostly from https://gnu.xyz/auto_theme.html, but also +;; somewhere else (which I've forgotten) and my own brain :) + +;;; Code: + +(require 'calendar) +(require 'cl-lib) +(require 'solar) + +(defvar dawn--dawn-timer nil + "Timer for dawn-command.") + +(defvar dawn--dusk-timer nil + "Timer for dusk-command.") + +(defvar dawn--reset-timer nil + "Timer to reset dawn at midnight.") + +(defun dawn-encode-time (f) + "Encode fractional time F." + (let ((hhmm (cl-floor f)) + (date (cdddr (decode-time)))) + (encode-time + (append (list 0 + (round (* 60 (cadr hhmm))) + (car hhmm) + ) + date)))) + +(defun dawn-midnight () + "Return the time of the /next/ midnight." + (let ((date (cdddr (decode-time)))) + (encode-time + (append (list 0 0 0 (1+ (car date))) (cdr date))))) + +(defun dawn-sunrise () + "Return the time of today's sunrise." + (dawn-encode-time (caar (solar-sunrise-sunset (calendar-current-date))))) + +(defun dawn-sunset () + "Return the time of today's sunset." + (dawn-encode-time (caadr (solar-sunrise-sunset (calendar-current-date))))) + +(defun dawn-schedule (dawn-command dusk-command) + "Run DAWN-COMMAND at sunrise, and DUSK-COMMAND at dusk. +RESET is an argument for internal use." + (when (or (null calendar-longitude) + (null calendar-latitude)) + (user-error "`dawn' won't work without setting %s!" + (cond ((and (null calendar-longitude) + (null calendar-latitude)) + "`calendar-longitude' and `calendar-latitude'") + ((null calendar-longitude) + "`calendar-longitude'") + ((null calendar-latitude) + "`calendar-latitude'")))) + (let ((dawn (dawn-sunrise)) + (dusk (dawn-sunset))) + (cond + ((time-less-p nil dawn) + ;; If it isn't dawn yet, it's still dark. Run DUSK-COMMAND and schedule + ;; DAWN-COMMAND and DUSK-COMMAND for later. + (funcall dusk-command) + (run-at-time dawn nil dawn-command) + (run-at-time dusk nil dusk-command)) + ((time-less-p nil dusk) + ;; If it isn't dusk yet, it's still light. Run DAWN-COMMAND and schedule + ;; DUSK-COMMAND. + (funcall dawn-command) + (run-at-time dusk nil dusk-command)) + (t ;; Otherwise, it's past dusk, so run DUSK-COMMAND. + (funcall dusk-command))) + ;; Schedule a reset at midnight, to re-calculate dawn/dusk times. + ;(unless reset) + (run-at-time (dawn-midnight) nil + #'dawn-schedule dawn-command dusk-command))) + +(provide 'dawn) +;;; dawn.el ends here diff --git a/lisp/yoke.el b/lisp/yoke.el index 1e1bc60..f9c4d49 100644 --- a/lisp/yoke.el +++ b/lisp/yoke.el @@ -64,8 +64,8 @@ Execute BODY afterward. (url (cond ((consp package) (cdr package)) (:else nil))) (pname (intern (format "yoke:%s" pkg))) - (dirvar (gensym "yoke-dir-")) - ;; Keyword args + (dirvar '$yoke-dir) + ;; Keyword args --- TODO: Naming could probably be better. (after (plist-get body :after)) (depends (plist-get body :depends)) (whenp (plist-member body :when)) @@ -77,6 +77,7 @@ Execute BODY afterward. (autoload (cond ((plist-member body :autoload) (plist-get body :autoload)) (:else t))) + (pre (plist-get body :pre)) ;; Body (body (cl-loop for (this next) on body by #'cddr unless (keywordp this) @@ -102,12 +103,17 @@ Execute BODY afterward. `((when ,unless (cl-return-from ,pname (format "%s (abort) :unless %S" ',pname ',unless)))))) + ;; Evaluate `:pre' forms + ,@pre ;; Get prerequisite packages ,@(cl-loop for (pkg* . yoke-get-args) in depends collect `(or - (let ((dir (yoke-get ,@yoke-get-args - :dir ,(format "%s" pkg*)))) + (let* ((pkg-spec (yoke-get ,@yoke-get-args + :dir ,(format "%s" pkg*))) + (dir (expand-file-name (or (plist-get (cdr pkg-spec) :load) + "") + (car pkg-spec)))) (and dir ,@(if autoload `((yoke-generate-autoloads ',pkg* dir)) @@ -118,13 +124,16 @@ Execute BODY afterward. ',pkg*)))) ;; Download the package, generate autoloads ,@(when url - `((let ((,dirvar (yoke-get ,@url :dir ,(format "%s" pkg)))) + `((let* ((pkg-spec (yoke-get ,@url :dir ,(format "%s" pkg))) + (,dirvar (expand-file-name (or (plist-get (cdr pkg-spec) :load) + "") + (car pkg-spec)))) ,@(when autoload `((yoke-generate-autoloads ',pkg ,dirvar))) (add-to-list 'yoke-dirs ,dirvar nil #'string=)))) ;; Evaluate the body, optionally after the features in `:after' ,@(cond (after - `((eval-after ,after ,@body))) + `((yoke-eval-after ,after ,@body))) (:else body))) (:success ',package) (t (message "%s: %s (%s)" ',pname (car err) (cdr err)) @@ -144,7 +153,7 @@ ARGS is a plist with the following possible keys: download URL." (let* ((dir (plist-get args :dir)) (load (plist-get args :load)) - (type (plist-get args :type)) + (type (or (plist-get args :type))) (path (cond ((eq type 'http) (yoke-get-http url dir)) ((or (eq type 'git) @@ -159,7 +168,7 @@ ARGS is a plist with the following possible keys: (cond ((file-exists-p path) (add-to-list 'load-path (expand-file-name (or load "") path)) - path) + (cons path args)) (:else (error "Directory \"%s\" doesn't exist." path) nil)))) @@ -178,7 +187,18 @@ If DIR isn't given, it's guessed from the final component of the URL's path and placed under `yoke-dir'." (let* ((dir (yoke-get--guess-directory url dir)) (basename (file-name-nondirectory url)) - (filename (expand-file-name basename dir))) + ;; XXX: Is this the best idea?? PROBABLY NOT!!! Ideally I'd have + ;; a parameter (either dynamic var or passed in) that would give the + ;; name of the downloaded file. But that would take a bit of + ;; re-engineering, I think. So for now, it stays thus. + (filename (expand-file-name + (replace-regexp-in-string + (rx "-" (+ digit) ; major version + (+ (group "." (+ digit))) ; following version numbers + (group "." (+ (not space)))) ; extension + "\\2" + basename) + dir))) (cond ((file-exists-p filename) dir) (:else @@ -187,6 +207,8 @@ URL's path and placed under `yoke-dir'." (url-retrieve-synchronously url)) (condition-case e (progn + (goto-char (point-min)) + (delete-region (point) (+ 1 (re-search-forward "^$"))) (make-directory dir :parents) (write-file filename 1) (message "Downloading %s... Done" url)) @@ -264,7 +286,7 @@ BODY after Emacs is finished initializing." (rest (cdr features))) (cond ((eq this 'init) `(yoke--eval-after-init - (lambda () (eval-after ,rest ,@body)))) + (lambda () (yoke-eval-after ,rest ,@body)))) (:else `(with-eval-after-load ',this (yoke-eval-after ,rest ,@body))))))) @@ -277,21 +299,51 @@ BODY after Emacs is finished initializing." (setf (alist-get "Yoke" imenu-generic-expression nil nil #'equal) (list (rx (: "(yoke" (+ space) (? "(") (group (+ (not (or "(" " " "\t" "\n")))) - (+ space) - (group (+ (not space))))) + (* any))) 1))) -(defun yoke-compile () +;;; Package maintenance + +(defvar yoke--all "*all*" + "Value that `yoke--prompt-for-package' uses for all packages.") + +(defun yoke--choose-packages (prompt &optional onep) + "Choose from all of yoke's installed packages." + (funcall (if onep #'completing-read #'completing-read-multiple) + prompt + (cons yoke--all yoke-dirs) + nil :require-match nil nil + (unless onep yoke--all))) + +(defun yoke--choices (&optional selections) + "Either the SELECTIONS given, or all of `yoke-dirs'. +If `yoke--all' is part of SELECTIONS, or if it's not given, +return the full list of `yoke-dirs'." + (cond ((or (null selections) + (member yoke--all selections)) + yoke-dirs) + (:else selections))) + +(defun yoke-compile (&rest packages) "Compile all elisp files in `yoke-dirs'." - (interactive) - (dolist (dir yoke-dirs) + (interactive (yoke--choose-packages "Compile packages: ")) + (dolist (dir (yoke--choices packages)) (byte-recompile-directory dir 0))) +(defun yoke-update-autoloads (&rest packages) + "Update the autoloads in PACKAGES' directories." + (interactive (yoke--choose-packages "Generate autoloads for packages: ")) + (dolist (dir (yoke--choices packages)) + (message "Generating autoloads for %s..." dir) + (yoke-generate-autoloads (file-name-nondirectory dir) dir) + (message "Generating autoloads for %s... Done" dir))) + (defun yoke-remove (dir) + "Remove DIR from `yoke-dir'." (interactive - (completing-read "Remove: " yoke-dirs - nil :require-match)) - (delete-file dir :trash)) + (list (completing-read "Remove: " yoke-dirs + nil :require-match))) + (delete-directory dir :recursive :trash)) (provide 'yoke) ;;; yoke.el ends here -- cgit 1.4.1-21-gabe81