diff options
Diffstat (limited to 'lib')
45 files changed, 3069 insertions, 2797 deletions
diff --git a/lib/doc/jao-doc-session.el b/lib/doc/jao-doc-session.el new file mode 100644 index 0000000..a846302 --- /dev/null +++ b/lib/doc/jao-doc-session.el @@ -0,0 +1,64 @@ +;;; jao-doc-session.el --- persistent document sessions -*- lexical-binding: t; -*- + +;; Copyright (C) 2022, 2024, 2025, 2026 jao + +;; Author: jao <mail@jao.io> +;; Keywords: docs + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'multisession) + +(define-multisession-variable jao-doc--session nil) + +(defun jao-doc-session () (multisession-value jao-doc--session)) + +(defvar-local jao-doc-session-is-doc nil + "Locally marks a buffer as belonging to a session. + +See also `jao-doc-session-mark'.") + +(defun jao-doc-session-is-doc (&optional buffer) + "Check whether the given or current buffer belong to the doc session." + (buffer-local-value 'jao-doc-session-is-doc (or buffer (current-buffer)))) + +(defun jao-doc-session-save (&optional skip-current force) + "Traverse all current buffers and update the value of `jao-doc-session'." + (interactive) + (let ((docs '()) + (cb (and skip-current (current-buffer)))) + (dolist (b (buffer-list)) + (when-let* ((fs (and (not (eq cb b)) (jao-doc-session-is-doc b))) + (fs (if (listp fs) fs (list (buffer-file-name b))))) + (dolist (f fs) (push f docs)))) + (when (or force (> (length docs) 0)) + (setf (multisession-value jao-doc--session) docs)))) + +(defun jao-doc-session-mark (&optional path) + "Mark the current buffer's file, or PATH, as persistent across sessions." + (unless (listp jao-doc-session-is-doc) + (setq jao-doc-session-is-doc (ensure-list jao-doc-session-is-doc))) + (cl-pushnew (or path (buffer-file-name)) jao-doc-session-is-doc) + (jao-doc-session-save)) + +(defun jao-doc-session--maybe-save () + (when (jao-doc-session-is-doc) (jao-doc-session-save t))) + +(add-hook 'kill-buffer-hook #'jao-doc-session--maybe-save) +(add-hook 'kill-emacs-hook #'jao-doc-session-save) + +(provide 'jao-doc-session) +;;; jao-doc-session.el ends here diff --git a/lib/doc/jao-doc-view.el b/lib/doc/jao-doc-view.el index ea55565..74c4751 100644 --- a/lib/doc/jao-doc-view.el +++ b/lib/doc/jao-doc-view.el @@ -1,6 +1,6 @@ -;; jao-doc-view.el -- Remembering visited documents -*- lexical-binding: t; -*- +;;; jao-doc-view.el -- extensions for doc-view -*- lexical-binding: t; -*- -;; Copyright (c) 2013, 2015, 2017, 2018, 2019, 2021, 2022 Jose Antonio Ortega Ruiz +;; Copyright (c) 2013, 2015, 2017, 2018, 2019, 2021, 2022, 2026 Jose Antonio Ortega Ruiz ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -18,219 +18,111 @@ ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> ;; Start date: Fri Feb 15, 2013 01:21 -;;; Comentary: - -;; Some utilities to keep track of visited documents and their structure. - -;;; Code: - - -;;; Session - +(require 'browse-url) +(require 'thingatpt) (require 'doc-view) +(require 'jao-pdf) -(defvar jao-doc-view-session-file "~/.emacs.d/cache/doc-view-session.eld") -(defvar-local jao-doc-view--is-doc nil) - -(defun jao-doc-view-session-mark (path) (setq-local jao-doc-view--is-doc path)) -(defun jao-doc-view--is-doc () - (or jao-doc-view--is-doc - (when (derived-mode-p 'doc-view-mode 'pdf-view-mode 'nov-mode) - (buffer-file-name)))) +(declare-function pdf-view-image-size "pdf-view") +(declare-function pdf-view-goto-page "pdf-view") +(declare-function pdf-view-current-page "pdf-view") -(defun jao-doc-view--read-file (file) - (let ((buff (find-file-noselect file))) - (ignore-errors - (with-current-buffer buff - (goto-char (point-min))) - (read buff)))) +;;; Utilities -(defun jao-doc-view--save-to-file (file value) - (with-current-buffer (find-file-noselect file) - (erase-buffer) - (insert (format "%S" value)) - (save-buffer))) - -(defun jao-doc-view-session (&optional file) - (let ((file (or file jao-doc-view-session-file))) - (jao-doc-view--read-file file))) - -(defun jao-doc-view-save-session (&optional skip-current) - (interactive) - (let ((docs '()) - (cb (when skip-current (current-buffer)))) - (dolist (b (buffer-list)) - (with-current-buffer b - (when-let (fn (and (not (eq cb b)) (jao-doc-view--is-doc))) - (add-to-list 'docs fn)))) - (when (> (length docs) 0) - (jao-doc-view--save-to-file jao-doc-view-session-file docs)))) - -(defun jao-doc-view--save-session-1 () - (when (jao-doc-view--is-doc) (jao-doc-view-save-session t))) - -(defvar jao-doc-view-inhibit-session-save nil) - -(defun jao-doc-view--save-session () - (let ((inhibit-message t) - (message-log-max nil)) - (when (not jao-doc-view-inhibit-session-save) - (jao-doc-view-save-session)) - t)) - -(add-hook 'kill-emacs-query-functions #'jao-doc-view--save-session) -(add-hook 'kill-buffer-hook #'jao-doc-view--save-session-1) -(add-hook 'doc-view-mode-hook #'jao-doc-view--save-session) -(add-hook 'pdf-view-mode-hook #'jao-doc-view--save-session) -(add-hook 'nov-mode-hook #'jao-doc-view--save-session) - - -;;; PDF info - -(defvar-local jao--pdf-outline nil) - -(defmacro jao-doc-view--pdf-call (a b &rest args) +(defmacro jao-doc-view--funcall (a b &rest args) `(cond ((derived-mode-p 'pdf-view-mode) (,a ,@args)) ((derived-mode-p 'doc-view-mode) (,b ,@args)))) -(defun jao-doc-view-is-pdf (file) (string-match-p ".*\\.pdf$" file)) - -(defun jao-doc-view-title->file (title) - (concat (mapconcat 'downcase (split-string title nil t) "-") ".pdf")) - (defun jao-doc-view-current-page () - (jao-doc-view--pdf-call pdf-view-current-page doc-view-current-page)) + (jao-doc-view--funcall pdf-view-current-page doc-view-current-page)) (defun jao-doc-view-goto-page (page &optional height) (when page - (jao-doc-view--pdf-call pdf-view-goto-page doc-view-goto-page page)) + (jao-doc-view--funcall pdf-view-goto-page doc-view-goto-page page)) (when (and height (derived-mode-p 'pdf-view-mode)) (image-set-window-vscroll (round (/ (* height (cdr (pdf-view-image-size))) (frame-char-height)))))) -(defun jao-doc-view-pdf-outline (&optional file-name) - (if (derived-mode-p 'pdf-view-mode) - (pdf-info-outline) - (let* ((outline nil) - (fn (or file-name (buffer-file-name) jao-doc-view--imenu-file)) - (fn (shell-quote-argument (expand-file-name fn)))) - (with-temp-buffer - (insert (shell-command-to-string (format "mutool show %s outline" fn))) - (goto-char (point-min)) - (while (re-search-forward ".+\\(\t+\\)\"\\(.+\\)\"\t#\\([0-9]+\\)," nil t) - (push `((level . ,(length (match-string 1))) - (title . ,(match-string 2)) - (page . ,(string-to-number (match-string 3)))) - outline))) - (nreverse outline)))) - -(defun jao-doc-view-section-title (&optional page file-name) - (when (not jao--pdf-outline) - (setq-local jao--pdf-outline (jao-doc-view-pdf-outline file-name))) - (let ((page (or page (jao-doc-view-current-page))) - (outline jao--pdf-outline) - (cur-page 0) - (cur-title (jao-doc-view-title (or file-name buffer-file-name "title")))) - (while (and (car outline) (< cur-page page)) - (setq cur-page (cdr (assoc 'page (car outline)))) - (when (<= cur-page page) - (setq cur-title (cdr (assoc 'title (car outline))))) - (setq outline (cdr outline))) - (replace-regexp-in-string "[[:blank:]]+" " " cur-title))) - -(defun jao-doc-view-title (&optional fname) - (if (or fname (not (derived-mode-p 'doc-view-mode 'pdf-view-mode))) - (let ((base (file-name-base (or fname (buffer-file-name))))) - (capitalize (replace-regexp-in-string "-" " " base))) - (or (jao-doc-view-section-title) - (when buffer-file-name (jao-doc-view-title buffer-file-name))))) - - ;;; imenu -(defvar-local jao-doc-view--imenu-file nil) -(defvar-local jao-doc-view--goer 'jao-doc-view-goto-page) - -(defun jao-doc-view--enable-imenu (&optional file-name goto-page) - (setq-local imenu-create-index-function #'jao-doc-view--imenu-create-index - jao-doc-view--imenu-file (or file-name jao-doc-view--imenu-file) - jao-doc-view--goer (or goto-page 'jao-doc-view-goto-page)) - (imenu-add-to-menubar "PDF outline")) - -(defun jao-doc-view--imenu-create-index () - (let (index) - (dolist (item (or jao--pdf-outline - (setq jao--pdf-outline - (jao-doc-view-pdf-outline jao-doc-view--imenu-file)))) - (let-alist item - (let* ((lvl (make-string (max 0 (1- .level)) ?.)) - (title (format "%s%s (%s)" lvl .title .page))) - (push `(,title 0 jao-doc-view--go ,item) index)))) - (nreverse index))) - -(defun jao-doc-view--go (&rest args) - (when-let (item (car (last args))) - (let-alist item (funcall jao-doc-view--goer .page)))) - -(add-hook 'doc-view-mode-hook #'jao-doc-view--enable-imenu) - - +(defun jao-doc-view-enable-imenu (file-name goto-page) + (let ((ifun (lambda () (doc-view-imenu-index file-name goto-page)))) + (doc-view-imenu-setup) + (setq-local imenu-create-index-function ifun))) + ;;; Page trailing (defvar-local jao-doc-view--trail-back ()) (defvar-local jao-doc-view--trail-fwd ()) -(defun jao-doc-view--trail-push (dest-page) - (when-let (page (jao-doc-view-current-page)) +(defun jao-doc-view--trail-push (_dest-page) + (when-let* ((page (jao-doc-view-current-page))) (unless (eq (car jao-doc-view--trail-back) page) - (push page jao-doc-view--trail-back)))) + (cl-pushnew page jao-doc-view--trail-back)))) (defun jao-doc-view-back () (interactive nil doc-view-mode) - (if-let (p (pop jao-doc-view--trail-back)) - (progn (push (jao-doc-view-current-page) jao-doc-view--trail-fwd) + (if-let* ((p (pop jao-doc-view--trail-back))) + (progn (cl-pushnew (jao-doc-view-current-page) jao-doc-view--trail-fwd) (jao-doc-view-goto-page p)) (message "No more back marks."))) (defun jao-doc-view-forward () (interactive nil doc-view-mode) - (if-let (p (pop jao-doc-view--trail-fwd)) + (if-let* ((p (pop jao-doc-view--trail-fwd))) (progn (push (jao-doc-view-current-page) jao-doc-view--trail-back) (jao-doc-view-goto-page p)) (message "No more forward marks."))) (advice-add 'doc-view-goto-page :before #'jao-doc-view--trail-push) - +;;; Extract text +(defun jao-doc-view-page-text (&optional re-render no-select) + (interactive "P") + (let* ((pno (doc-view-current-page)) + (in buffer-file-name) + (cdir (or (doc-view--current-cache-dir) "/tmp")) + (out (format "%s/p%s.txt" cdir pno))) + (when (and (file-exists-p out) re-render) + (delete-file out)) + (unless (file-exists-p out) + (shell-command-to-string (format "mutool convert -o %s %s %s" out in pno))) + (if no-select + out + (find-file out) + (view-mode)))) + +(define-key doc-view-mode-map "t" #'jao-doc-view-page-text) + ;;; Find URLs -(defun jao-doc-view--page-urls (all) - (if doc-view--current-converter-processes - (message "DocView: please wait till conversion finished.") - (let ((txt (expand-file-name "doc.txt" (doc-view--current-cache-dir))) - (page (doc-view-current-page)) - (pd-rx (rx (+ (literal page-delimiter)))) - (urls)) - (if (file-readable-p txt) - (with-current-buffer (find-file-noselect txt) - (goto-char (point-min)) - (unless all (re-search-forward pd-rx nil t (1- page))) - (let ((end (save-excursion - (if (and (not all) (re-search-forward pd-rx nil t)) - (point) - (point-max))))) - (while (re-search-forward "https?://" end t) - (push (thing-at-point-url-at-point) urls)) - urls)) - (doc-view-doc->txt txt (lambda () (jao-doc-view--page-urls all))) - 'wait)))) +(defun jao-doc-view--full-txt () + (expand-file-name "doc.txt" (doc-view--current-cache-dir))) + +(defun jao-doc-view--collect-urls (file) + (with-current-buffer (find-file-noselect file) + (goto-char (point-min)) + (let ((urls nil)) + (while (re-search-forward "https?://" nil t) + (push (thing-at-point-url-at-point) urls)) + urls))) + +(defun jao-doc-view--page-urls (&optional all) + (let ((txt (jao-doc-view--full-txt))) + (cond ((and all (not (file-exists-p txt))) + (message "Full text not extracted yet: doing so!") + (doc-view-doc->txt txt (lambda () (message "Text extracted"))) + 'wait) + (all (jao-doc-view--collect-urls txt)) + (t (jao-doc-view--collect-urls (jao-doc-view-page-text nil t)))))) (defun jao-doc-view-visit-url (all) "Visit URL displayed in this page." - (interactive "P" doc-view-mode) + (interactive "P") (let ((urls (jao-doc-view--page-urls all))) (cond ((eq 'wait urls) (message "Extracting text, please wait and retry.")) - ((zerop (length urls)) (message "No URLs in this page")) - (t (when-let (url (completing-read "URL: " urls nil nil - (when (null (cdr urls)) (car urls)))) + ((zerop (length urls)) + (message "No URLs in this %s" (if all "document" "page"))) + (t (when-let* ((url (completing-read "URL: " urls nil nil + (when (null (cdr urls)) (car urls))))) (browse-url url)))))) - +;;; . (provide 'jao-doc-view) diff --git a/lib/doc/jao-org-focus.el b/lib/doc/jao-org-focus.el new file mode 100644 index 0000000..a8d72be --- /dev/null +++ b/lib/doc/jao-org-focus.el @@ -0,0 +1,154 @@ +;;; jao-org-focus.el --- focusing on org subtrees -*- lexical-binding: t; -*- + +;; Copyright (C) 2025, 2026 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <mail@jao.io> +;; Keywords: docs + +;; 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 <https://www.gnu.org/licenses/>. + +(require 'org) +(require 'cl-lib) + +(defvar-local jao-org-focus--parent nil) +(defvar-local jao-org-focus--section nil) + +(defvar jao-org-focus-siblings '("escaleta.org" . "novela.org")) + +(defun jao-org-focus--header-title () + (when-let* ((elem (org-element-at-point)) + (header (if (eq 'headline (org-element-type elem)) + elem + (org-previous-visible-heading 1) + (org-element-at-point)))) + (org-element-property :title header))) + +(defun jao-org-focus--is-outline () + (string= (car jao-org-focus-siblings) + (file-name-nondirectory (or (buffer-file-name) "")))) + +(defun jao-org-focus--jump-to-title (file title) + (let* ((file (if (bufferp file) (buffer-file-name file) file)) + (link (format "[[%s::*%s]]" file title))) + (org-link-open-from-string link))) + +(defun jao-org-focus-jump-to-sibling () + (interactive) + (when-let* ((title (save-excursion (jao-org-focus--header-title))) + (file (if (jao-org-focus--is-outline) + (cdr jao-org-focus-siblings) + (car jao-org-focus-siblings))) + (link (format "[[./%s::*%s]]" file title))) + (jao-org-focus--jump-to-title (format "./%s" file) title))) + +;;; focus on subtree +;;;###autoload +(defun jao-org-focus () + "Pop creatingly to an indirect buffer focused on the encloing subtree. + +When invoked on an indirect buffer, pops back to its base." + (interactive) + (when (jao-org-focus--is-outline) + (jao-org-focus-jump-to-sibling)) + (if-let* ((b (get-buffer (or jao-org-focus--parent "")))) + (let ((title (save-excursion + (goto-char (point-min)) + (jao-org-focus--header-title)))) + (jao-org-focus--jump-to-title b title)) + (when-let* ((title (jao-org-focus--header-title)) + (parent (buffer-name)) + (bname (format "%s [%s]" title parent))) + (if-let* ((b (get-buffer bname))) + (pop-to-buffer b) + (clone-indirect-buffer bname t) + (org-focus-mode -1) + (org-focus-child-mode) + (setq jao-org-focus--parent parent + jao-org-focus--section title) + (org-narrow-to-subtree) + (outline-show-subtree) + (count-words (point-min) (point-max)))))) + +(defun jao-org-focus-redisplay () + "Redisplay a focused buffer. + +Useful when its parent has been reorganised and the narrowing is out of +sync." + (interactive) + (when-let* ((title jao-org-focus--section)) + (widen) + (goto-char (point-min)) + (when (re-search-forward (format "\\*+ %s" title) nil t) + (org-narrow-to-subtree) + (goto-char (point-min))))) + +(defun jao-org-focus-redisplay-children () + "Find focused children and redisplay them." + (interactive) + (dolist (b (jao-org-focus-list)) + (with-current-buffer b + (save-excursion (jao-org-focus-redisplay))))) + +(defun jao-org-focus-list (&optional any-parent exclude) + "List of buffers that are focusing on a subtree of this one or its parent." + (let ((n (or jao-org-focus--parent (buffer-name)))) + (seq-filter (lambda (b) + (let ((p (buffer-local-value 'jao-org-focus--parent b))) + (and p + (or any-parent (string= n p)) + (or (not exclude) + (not (string= (buffer-name b) exclude)))))) + (buffer-list)))) + +(defvar jao-org-focus--focused-history nil) + +(defun jao-org-focus-switch (arg) + "Read with completion a focused child and pop to it. + +With arg, offer to switch to all children, regardless of their parent." + (interactive "P") + (let ((fl (mapcar 'buffer-name (jao-org-focus-list arg (buffer-name))))) + (unless fl (error "No focused children")) + (pop-to-buffer + (completing-read "Focused child: " fl + nil t nil 'jao-org-focus--focused-history)))) + +(define-minor-mode org-focus-mode + "A mode where keeping track of focused children is on by default." + :lighter " â—Ž" + :keymap '(("\C-ce" . jao-org-focus-jump-to-sibling) + ("\C-cl" . jao-org-focus-switch) + ("\C-cR" . jao-org-focus-redisplay) + ("\C-co" . jao-org-focus) + ("\C-cw" . count-words)) + (if org-focus-mode + (add-hook 'after-save-hook #'jao-org-focus-redisplay-children nil t) + (remove-hook 'after-save-hook #'jao-org-focus-redisplay-children t))) + +(define-minor-mode org-focus-child-mode + "A mode for the children of a focused org buffer." + :lighter " â—‰" + :keymap org-focus-mode-map + (when (and org-focus-child-mode (require 'symbol-overlay nil t)) + (face-remap-reset-base 'symbol-overlay-default-face) + (face-remap-add-relative 'symbol-overlay-default-face 'warning 'underline) + (symbol-overlay-mode 1))) + +(with-eval-after-load 'symbol-overlay + (keymap-set org-focus-mode-map "M-n" 'symbol-overlay-jump-next) + (keymap-set org-focus-mode-map "M-p" 'symbol-overlay-jump-prev)) + + +(provide 'jao-org-focus) +;;; jao-org-focus.el ends here diff --git a/lib/doc/jao-org-links.el b/lib/doc/jao-org-links.el index 9102927..fc1a241 100644 --- a/lib/doc/jao-org-links.el +++ b/lib/doc/jao-org-links.el @@ -1,25 +1,28 @@ ;; -*- lexical-binding: t; -*- -(require 'pdf-tools nil t) - +(require 'org) +(require 'browse-url) (require 'jao-org-notes) (require 'jao-doc-view) - -(declare pdf-info-outline "pdf-info") +(require 'jao-doc-session) +(require 'jao-pdf) +(require 'jao-afio) (defvar jao-org--sink-dir "./") -(defvar jao-org-open-pdf-fun #'jao-org--pdf-tools-open) +(defvar jao-org-open-pdf-fun #'jao-org--default-open) -(defun jao-org--pdf-tools-open (path page &optional height) +(defun jao-org--default-open (path page &optional height) (org-open-file path 1) (jao-doc-view-goto-page page height)) (defun jao-org--pdf-open (path page &optional height) - (funcall (or jao-org-open-pdf-fun #'jao-org--pdf-tools-open) path page height)) + (when (file-exists-p path) (jao-doc-session-mark path)) + (funcall (or jao-org-open-pdf-fun #'jao-org--default-open) path page height)) (defun jao-org-links--open-pdf (link) - "Open LINK in pdf-view-mode." - (cond ((string-match "\\(.*\\)::\\([0-9]*\\)\\+\\+\\([[0-9]\\.*[0-9]*\\)" link) + "Open LINK using `jaor-org-open-pdf-fn'." + (cond ((string-match "\\(.*\\)::\\([0-9]*\\)\\+\\+\\([[0-9]\\.*[0-9]*\\)" + link) (let* ((path (match-string 1 link)) (page (string-to-number (match-string 2 link))) (height (string-to-number (match-string 3 link)))) @@ -39,15 +42,15 @@ (read-file-name "Import file: " jao-org--sink-dir link link)))) (rename-file real-file dest-path))) - (if (jao-doc-view-is-pdf dest-path) + (if (jao-pdf-is-pdf-file dest-path) (jao-org-links--open-pdf full-link) (browse-url (format "file://%s" (expand-file-name dest-path)))))) (defun jao-org-links--complete-doc (&optional arg) (let ((default-directory jao-org--sink-dir)) (let ((f (replace-regexp-in-string "^file:" "doc:" - (org-file-complete-link arg)))) - (if (jao-doc-view-is-pdf f) + (org-link-complete-file arg)))) + (if (jao-pdf-is-pdf-file f) (let ((page (read-from-minibuffer "Page: " ""))) (if (> (string-to-number page) 0) (concat f "::" (read-from-minibuffer "Page: " "")) @@ -63,7 +66,7 @@ (when (derived-mode-p 'pdf-view-mode 'doc-view-mode) (jao-org-links-store-pdf-link buffer-file-name (jao-doc-view-current-page) - (jao-doc-view-section-title))))) + (jao-pdf-section-title))))) ;;;###autoload (defun jao-org-links-store-pdf-link (path page title) @@ -75,56 +78,65 @@ ;;;###autoload (defun jao-org-insert-doc (title) (interactive "sDocument title: ") - (insert (format "[[doc:%s][%s]]" (jao-doc-view-title->file title) title))) - -;;;###autoload -(defun jao-org-org-to-pdf-file () - (expand-file-name (concat "doc/" (file-name-base buffer-file-name) ".pdf") - (file-name-directory jao-org-notes-dir))) + (insert (format "[[doc:%s][%s]]" (jao-pdf-title-to-file-name title) title))) ;;;###autoload -(defun jao-org-pdf-to-org-file (&optional file-name) - (let* ((file-name (or file-name buffer-file-name)) - (bn (file-name-base file-name)) - (rx (format "%s\\.org$" (regexp-quote bn)))) - (save-some-buffers nil - (lambda () - (string-prefix-p jao-org-notes-dir buffer-file-name))) - (or (car (directory-files-recursively jao-org-notes-dir rx)) - (let* ((dirs (jao-org-notes-cats)) - (dir (completing-read "Notes subdir: " dirs nil t))) - (expand-file-name (concat dir "/" bn ".org") jao-org-notes-dir))))) +(defun jao-org-open-from-zathura (title &optional no-ask) + (when-let* ((info (jao-pdf-zathura-file-info title)) + (pdf-file (car info)) + (page (cadr info)) + (file (jao-org-notes-find-for-pdf pdf-file))) + (jao-afio-goto-docs) + (let ((exists (file-exists-p file))) + (find-file file) + (unless exists (jao-org-insert-doc-skeleton)) + (let ((lnk (jao-pdf--zathura-link info))) + (jao-doc-session-mark) + (if (or (not exists) (and (not no-ask) (y-or-n-p "Insert link?"))) + (insert lnk "\n") + (kill-new lnk) + (message "Link to %s (%s) killed" file page)))))) ;;;###autoload (defun jao-org-insert-doc-skeleton (&optional title) - (insert "#+title: " (or title (jao-doc-view-title (buffer-file-name))) + (insert "#+title: " (or title (jao-pdf-title (buffer-file-name))) "\n#+author:\n#+filetags: ") (jao-org-notes-insert-tags) (insert "\n#+startup: latexpreview\n\n")) ;;;###autoload -(defun jao-org-pdf-goto-org (arg) +(defun jao-org-pdf-goto-org (arg &optional file-name) (interactive "P") - (when (jao-doc-view-is-pdf buffer-file-name) - (let* ((file (jao-org-pdf-to-org-file)) - (new (not (file-exists-p file))) - (title (jao-doc-view-title))) - (when (or arg new) (org-store-link nil t)) + (when (jao-pdf-is-pdf-file (or file-name buffer-file-name)) + (let* ((file (jao-org-notes-find-for-pdf file-name)) + (new (not (file-exists-p file)))) + (if (and (not file-name) (or arg new)) + (org-store-link nil t) + (when-let* ((fboundp 'jao-pdf-skim-org-link) + (lnk (jao-pdf-skim-org-link nil))) + (kill-new lnk))) (find-file-other-window file) (when new - (jao-org-insert-doc-skeleton title) + (jao-org-insert-doc-skeleton (jao-pdf-title file-name)) (org-insert-link))))) ;;;###autoload (defun jao-org-pdf-goto-org* () (interactive) (jao-org-pdf-goto-org t)) +(defun jao-org-org-to-pdf-file () + (expand-file-name (concat "doc/" (file-name-base buffer-file-name) ".pdf") + (file-name-directory jao-org-notes-dir))) + ;;;###autoload -(defun jao-org-org-goto-pdf () +(defun jao-org-goto-pdf () (interactive) - (if-let (f (jao-org-org-to-pdf-file)) - (find-file-other-window f) + (if-let* ((f (jao-org-org-to-pdf-file))) + (jao-org--pdf-open f nil) (user-error "No PDF file associated with this buffer"))) +(with-eval-after-load "org" + (define-key org-mode-map (kbd "C-c o") #'jao-org-goto-pdf)) + ;;;###autoload (defun jao-org-links-setup (sink-dir) (interactive) @@ -133,7 +145,6 @@ :complete #'jao-org-links--complete-doc :store #'jao-org-links--store-pdf-link) (org-link-set-parameters "docview" :store #'ignore) - (org-link-set-parameters "message" :follow #'jao-org-links-open-mail) (setq jao-org--sink-dir (file-name-as-directory sink-dir))) (provide 'jao-org-links) diff --git a/lib/doc/jao-org-notes.el b/lib/doc/jao-org-notes.el index 738c938..929ab66 100644 --- a/lib/doc/jao-org-notes.el +++ b/lib/doc/jao-org-notes.el @@ -1,6 +1,6 @@ ;;; jao-org-notes.el --- A simple system for org note taking -*- lexical-binding: t; -*- -;; Copyright (C) 2020, 2021, 2022 jao +;; Copyright (C) 2020, 2021, 2022, 2024, 2025, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: tools @@ -26,53 +26,88 @@ ;;; Code: (require 'org) (require 'consult) +(require 'jao-shell) (defvar jao-org-notes-dir (expand-file-name "notes" org-directory)) -(defun jao-org-notes--rg (str) +(defun jao-org-notes-list () + (directory-files-recursively jao-org-notes-dir "\\.org$")) + +(defun jao-org-notes--rg-cmd (rgx &rest args) `("rg" "--null" "--line-buffered" "--color=never" "--max-columns=250" - "--no-heading" "--line-number" "--smart-case" "." "-e" - ,(format "^(#.(title|filetags): .*)%s" str))) + "--type=org" "--line-number" "--no-heading" "--smart-case" "--follow" + ,@args ,default-directory "-e" ,rgx)) + +(defun jao-org-notes--rg-title-or-tags (str) + (let* ((m (string-match "^\\([^/]+\\)/\\(.*\\)" str)) + (d (or (and m (match-string 1 str)) "")) + (str (if m (match-string 2 str) str)) + (default-directory + (if (file-directory-p d) (expand-file-name d) default-directory)) + (ts (mapconcat #'identity (split-string str "[:,]+" t) ":|")) + (s (mapconcat #'identity (cons str (split-string str nil t)) "|")) + (rgx (format "^#.(title: .*(%s)|(tags:.*(%s:)))" s ts))) + (jao-org-notes--rg-cmd rgx "-m" "2"))) (defun jao-org-notes--clean-match (m) - (cons (format "%s %s" - (replace-regexp-in-string "^\\./" "" (car m)) - (replace-regexp-in-string "[0-9]+:#\\+\\(file\\)?\\(title\\|tags\\):" - " (\\2)" (cadr m))) - (expand-file-name (car m) default-directory))) + (list (format "%s %s" + (replace-regexp-in-string default-directory "" (car m) nil t) + (replace-regexp-in-string "[0-9]+:#\\+\\(title\\|tags\\):" + "" (cadr m))) + (expand-file-name (car m) default-directory) + (string-to-number (cadr m)))) (defun jao-org-notes--matches (lines) - (mapcar (lambda (l) (jao-org-notes--clean-match (split-string l "\0" t))) lines)) + (seq-keep (lambda (l) + (let ((m (split-string (or l "") "\0" t))) + (when (and (car m) (cadr m)) + (jao-org-notes--clean-match m)))) + lines)) + +(defun jao-org-notes--grep-rx (rx &rest rg-args) + (let ((default-directory jao-org-notes-dir)) + (jao-org-notes--matches + (apply #'jao-shell-cmd-lines (apply #'jao-org-notes--rg-cmd rx rg-args))))) (defvar jao-org-notes--grep-history nil) -(defun jao-org--grep (prompt &optional cat no-req) +(defun jao-org-notes--consult-group (m transform) + (or (and transform m) + (and (string-match-p "^[^:]+ + :" m) "tags") + "titles")) + +(defun jao-org-notes--consult-rg (prompt &optional cat no-req initial) (let ((default-directory (expand-file-name (or cat "") jao-org-notes-dir))) (consult--read - (consult--async-command #'jao-org-notes--rg - (consult--async-transform jao-org-notes--matches)) + (consult--async-pipeline + (consult--process-collection #'jao-org-notes--rg-title-or-tags) + (consult--async-transform #'jao-org-notes--matches)) :prompt prompt - :initial (consult--async-split-initial "") - :add-history (concat (consult--async-split-initial (thing-at-point 'symbol))) + :initial (or initial "") + :add-history (thing-at-point 'symbol) :require-match (not no-req) :category 'jao-org-notes-lookup + :group 'jao-org-notes--consult-group + :lookup (lambda (cand cands &rest _) + (or (cadr (assoc cand cands)) (substring cand 1))) :history '(:input jao-org-notes--grep-history)))) (defun jao-org-notes-cats () - (seq-difference (directory-files jao-org-notes-dir) '("." ".." "attic"))) + (directory-files jao-org-notes-dir nil "^[^.]")) (defun jao-org-notes--cat () (let* ((cat (completing-read "Top level category: " (jao-org-notes-cats)))) (cond ((file-exists-p (expand-file-name cat jao-org-notes-dir)) cat) - ((yes-or-no-p "New category, create?") cat) - (t (jao-roam--cat))))) + ((yes-or-no-p "New category, create?") cat)))) -(defun jao-org-notes--insert-title () +(defun jao-org-notes--insert-title (&optional title) (let* ((cat (jao-org-notes--cat)) - (title (file-name-base (jao-org--grep "Title: " cat t))) + (note (jao-org-notes--consult-rg "Title: " cat t title)) + (title (file-name-base note)) (title (replace-regexp-in-string "^#" "" title))) (when (not (string-empty-p title)) (let* ((base (replace-regexp-in-string " +" "-" (downcase title))) + (base (replace-regexp-in-string "[^-[:alnum:][:digit:]]" "" base)) (fname (expand-file-name (concat cat "/" base ".org") jao-org-notes-dir)) (exists? (file-exists-p fname))) @@ -81,85 +116,110 @@ (insert "#+title: " title "\n") t))))) -(defvar jao-org-notes--tags nil) -(defvar jao-org-notes-tags-cache-file "~/.emacs.d/cache/tags.eld") - -(defun jao-org-notes--save-tags () - (with-current-buffer (find-file-noselect jao-org-notes-tags-cache-file) - (delete-region (point-min) (point-max)) - (print jao-org-notes--tags (current-buffer)) - (let ((message-log-max nil) - (inhibit-message t)) - (save-buffer)))) +(defun jao-org-notes--find-tag (tag) + (jao-org-notes--grep-rx (format "^#.tags:.*:%s:" tag) "-m" "1")) -(defun jao-org-notes--read-tags-cache () - (let ((b (find-file-noselect jao-org-notes-tags-cache-file))) - (with-current-buffer b (goto-char (point-min))) - (setq jao-org-notes--tags (read b)))) +(defvar jao-org-notes--tags nil) +(defvar jao-org-notes--tag-history nil) (defun jao-org-notes--read-tags () - (unless jao-org-notes--tags (jao-org-notes--read-tags-cache)) - (let* ((tags (completing-read-multiple "Tags: " jao-org-notes--tags)) - (new-tags (seq-difference tags jao-org-notes--tags))) - (when new-tags - (setq jao-org--notes-tags - (sort (append new-tags jao-org-notes--tags) #'string<)) - (jao-org-notes--save-tags)) + (let* ((tags (completing-read-multiple "Tags: " + jao-org-notes--tags nil nil nil + 'jao-org-notes--tag-history))) + (setq jao-org-notes--tags (seq-union jao-org-notes--tags tags #'string=)) tags)) -(defun jao-org-notes--insert-tags () - (insert "#+filetags: " (mapconcat #'identity (jao-org-notes--read-tags) " ") "\n")) - -(defun jao-org-notes--insert-date () - (insert "#+date: ") - (org-insert-time-stamp (current-time)) - (insert "\n")) - (defun jao-org-notes--template (k) - `(,k "Note" plain (file jao-org-notes-open-or-create) - "\n- %a\n %i" - :jump-to-captured t)) + `(,k "Note" plain (file jao-org-notes-create) + "%(if %:url \"#+link: %:url\" \"\")\n\n- %a\n %i")) + +(defun jao-org-notes-all-tags () + (let ((tags nil)) + (dolist (m (jao-org-notes--find-tag ".*")) + (setq tags (seq-union tags (cdr (split-string (car m) ":" t))))) + (sort tags #'string<))) + +(defun jao-org-notes-find-for-pdf (&optional file-name) + "Given a PDF file name, find its org notes counterpart." + (let* ((file-name (or file-name buffer-file-name)) + (bn (file-name-base file-name)) + (rx (format "%s\\.org$" (regexp-quote bn))) + (pred (lambda () + (string-prefix-p jao-org-notes-dir buffer-file-name)))) + (save-some-buffers nil pred) + (or (car (directory-files-recursively jao-org-notes-dir rx)) + (let* ((d (completing-read "Notes subdir: " (jao-org-notes-cats) nil t)) + (d (file-name-as-directory d))) + (expand-file-name (concat d bn ".org") jao-org-notes-dir))))) ;;;###autoload (defun jao-org-notes-open () - "Search for a note file, matching tags and titles with completion." + "Search for a note file, matching tags and titles with completion. + +If the search string starts with a folder name followed by a +slash (e.g. `emacs/foo'), the search is performed only in the given +notes folder (when it exists). + +Search terms that start with a colon are interpreted as tags, and can +appear in any order in the tags list. +" (interactive) - (when-let (f (jao-org--grep "Search notes: ")) + (when-let* ((f (jao-org-notes--consult-rg "Search tags and titles: "))) (find-file f))) -;;;###autoload -(defun jao-org-notes-open-or-create () - "Open or create a new note file, matching tags and titles with completion." +(defvar jao-org-notes-consult-ripgrep-args + (format "%s -L" consult-ripgrep-args)) + +(defun jao-org-notes-consult-ripgrep (&optional ask initial) + "Search over notes in given notes categories (or all of them), using rg." + (interactive "P") + (let ((cat (when ask (completing-read "Category: " (jao-org-notes-cats)))) + (consult-ripgrep-args jao-org-notes-consult-ripgrep-args)) + (consult-ripgrep (expand-file-name (or cat "") jao-org-notes-dir) initial))) + +(defun jao-org-notes-consult-ripgrep-category (&optional initial) + "Search over notes in a given notes category." + (interactive "P") + (jao-org-notes-consult-ripgrep t initial)) + +(defun jao-org-notes-consult-tags () + "Search for a note file, matching all tags with completion." (interactive) - (when (jao-org-notes--insert-title) - (jao-org-notes--insert-date) - (jao-org-notes--insert-tags)) - (save-buffer) - (buffer-file-name)) + (let* ((tags (jao-org-notes--read-tags)) + (init (concat "^..tags: " (mapconcat #'identity tags " ")))) + (jao-org-notes-consult-ripgrep init))) -;;;###autoload -(defun jao-org-notes-grep (&optional initial) - "Perform a grep search on all org notes body, via consult-ripgrep." +(defun jao-org-notes-create (&optional title ret-buffer) + "Create a new note file, matching tags and titles with completion." (interactive) - (consult-ripgrep jao-org-notes-dir initial)) + (when (jao-org-notes--insert-title title) + (insert "#+tags: :" + (mapconcat #'identity (jao-org-notes--read-tags) ":") + ":\n") + (org-insert-time-stamp (current-time) t t "#+date: " "\n")) + (save-buffer) + (if ret-buffer (current-buffer) (buffer-file-name))) -;;;###autoload (defun jao-org-notes-backlinks () "Show a list of note files linking to the current one." (interactive) - (jao-org-notes-search (concat "\\[\\[file:\\(.*/\\)?" (buffer-name)))) + (if-let* ((res (jao-org-notes--grep-rx + (concat "\\[file:.*" (regexp-quote (buffer-name)) "\\]\\["))) + (file (completing-read "File: " res nil t nil)) + (entry (assoc file res))) + (progn (find-file (cadr entry)) + (when-let* ((line (caddr entry))) (goto-line line))) + (message "Nobody links here!"))) -;;;###autoload (defun jao-org-notes-insert-tags () "Insert a list of tags at point, with completing read." (interactive) - (insert (mapconcat 'identity (jao-org-notes--read-tags) " "))) + (insert ":" (mapconcat 'identity (jao-org-notes--read-tags) ":") ":")) -;;;###autoload (defun jao-org-notes-insert-link () "Select a note file (with completion) and insert a link to it." (interactive) - (when-let (f (jao-org--grep "Notes file: ")) + (when-let* ((f (jao-org-notes--consult-rg "Notes file: "))) (let ((rel-path (file-relative-name f default-directory)) (title (with-current-buffer (find-file-noselect f) (save-excursion @@ -168,11 +228,19 @@ (match-string 1)))))) (insert (format "[[file:%s][%s]]" rel-path title))))) +(defun jao-org-notes-stats () + (interactive) + (message "%d notes, %d tags in %s" + (length (jao-org-notes-list)) + (length jao-org-notes--tags) + jao-org-notes-dir)) + ;;;###autoload (defun jao-org-notes-setup (mnemonic) - "Set up the notes system, providing a mnemonic character for its org template." - (setq org-capture-templates - (add-to-list 'org-capture-templates (jao-org-notes--template mnemonic))) + "Set up the notes system, providing a mnemonic char for its org template." + (require 'org-capture) + (add-to-list 'org-capture-templates (jao-org-notes--template mnemonic)) + (setq jao-org-notes--tags (jao-org-notes-all-tags)) (when (fboundp 'org-capture-upgrade-templates) (org-capture-upgrade-templates org-capture-templates))) diff --git a/lib/doc/jao-pdf.el b/lib/doc/jao-pdf.el new file mode 100644 index 0000000..01334b1 --- /dev/null +++ b/lib/doc/jao-pdf.el @@ -0,0 +1,129 @@ +;;; jao-pdf.el --- utilities for pdf files -*- lexical-binding: t; -*- + +;; Copyright (C) 2022, 2025, 2026 jao + +;; Author: jao <mail@jao.io> +;; Keywords: docs + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Some niceties for PDFs: +;; +;; - Using mutools, we can extract the outline of PDFs, and tell back the +;; section title of a given page. +;; - Interoperability with zathura. + +(require 'jao-doc-session) +(require 'browse-url) + +;;; PDF info + +(declare-function 'pdf-info-outline "pdf-info") +(defvar jao-pdf-org-dir nil) + +(defun jao-pdf-org-dir () jao-pdf-org-dir) + +(defvar-local jao-pdf--outline nil) + +(defun jao-pdf-is-pdf-file (file) + "Simply checks the FILE extension." + (string-match-p ".*\\.pdf$" file)) + +(defun jao-pdf-title-to-file-name (title) + "Convert a title, possibly with embedded spaces, to a PDF filename." + (concat (mapconcat 'downcase (split-string title nil t) "-") ".pdf")) + +(defun jao-pdf-title (&optional fname) + (if (or fname (not (derived-mode-p 'doc-view-mode 'pdf-view-mode))) + (let ((base (file-name-base (or fname (buffer-file-name))))) + (capitalize (replace-regexp-in-string "-" " " base))) + (or (jao-pdf-section-title) + (when buffer-file-name (jao-pdf-title buffer-file-name))))) + +(defvar-local jao-pdf--outline nil) + +(defun jao-pdf-section-title (&optional page file-name) + (when (not jao-pdf--outline) + (setq-local jao-pdf--outline (doc-view--pdf-outline file-name))) + (let ((page (or page + (and (derived-mode-p 'doc-view-mode) (doc-view-current-page)) + (and (fboundp 'pdf-view-current-page) (pdf-view-current-page)))) + (outline jao-pdf--outline) + (cur-page 0) + (cur-title (jao-pdf-title (or file-name buffer-file-name "title")))) + (while (and (car outline) page (< cur-page page)) + (setq cur-page (cdr (assoc 'page (car outline)))) + (when (<= cur-page page) + (setq cur-title (cdr (assoc 'title (car outline))))) + (setq outline (cdr outline))) + (replace-regexp-in-string "[[:blank:]]+" " " cur-title))) + +;;; zathura interop +(defun jao-pdf-zathura-open-cmd (file page &optional suffix) + (let ((page (if page (format "-P %s" page) ""))) + (format "zathura %s %s %s" file page (or suffix "")))) + +(defun jao-pdf-zathura-title-rx (file) + (concat (file-name-nondirectory file) " \\[.+\\]")) + +;; e.g. "~/org/doc/write-yourself-a-scheme-in-48-hours.pdf [96 (96/138)]" +(defun jao-pdf-zathura-file-info (title) + (when (string-match "\\(.+\\) \\[\\(.+\\) (\\([0-9]+\\)/\\([0-9]+\\))\\]" + title) + (list (expand-file-name (match-string 1 title)) + (string-to-number (match-string 3 title)) + (string-to-number (match-string 4 title)) + (match-string 2 title)))) + +(defun jao-pdf--zathura-link (info) + (when-let* ((file (car info)) + (page (cadr info)) + (no (or (car (last info)) page)) + (fn (file-name-nondirectory file)) + (lnk (format "doc:%s::%s" fn page)) + (desc (format "%s (p. %s)" (jao-pdf-section-title page file) no))) + (org-link-make-string lnk desc))) + +(defun jao-pdf-zathura-org-link (title) + (jao-pdf--zathura-link (jao-pdf-zathura-file-info title))) + +;;; Open doc functions +(defvar jao-pdf-open-in-emacs t) + +(defun jao-open-doc (&optional file page height) + (interactive) + (when-let* ((file (or file + (read-file-name "Document: " + (concat (jao-pdf-org-dir) "/doc/"))))) + (funcall jao-open-doc-fun file page height))) + +;;; doc:// links for browse-url + +(defun jao-open-doc-url (url &rest _) + (when (string-match "doc://\\([^?]+\\)\\(\\?.*\\)?" url) + (let ((file (match-string 1 url)) + (page (when-let* ((qs (match-string 2 url)) + (long (> (length qs) 1)) + (ps (url-parse-query-string (substring qs 1))) + (pn (cadr (assoc "page" ps)))) + (string-to-number pn)))) + (jao-open-doc (expand-file-name (concat "doc/" file) jao-org-dir) page)))) + +(add-to-list 'browse-url-handlers (cons "^doc://.+" 'jao-open-doc-url)) + + +(provide 'jao-pdf) +;;; jao-pdf.el ends here diff --git a/lib/doc/jao-recoll.el b/lib/doc/jao-recoll.el deleted file mode 100644 index f43451f..0000000 --- a/lib/doc/jao-recoll.el +++ /dev/null @@ -1,116 +0,0 @@ -;; jao-recoll.el -- Displaying recoll queries - -;; Copyright (c) 2017, 2020, 2021, 2022 Jose Antonio Ortega Ruiz - -;; This file 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 file 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 <http://www.gnu.org/licenses/>. - -;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> -;; Start date: Wed Nov 01, 2017 18:14 - - -;;; Comentary: - -;; A simple interactive command to perform recoll queries and display -;; its results using org-mode. - -;;; Code: - - -(require 'org) - -(define-derived-mode recoll-mode org-mode "Recoll" - "Simple mode for showing recoll query results" - (read-only-mode 1)) - -(defvar jao-recoll--file-regexp - "\\(\\w+/.+\\)\t+\\[\\([^]]+\\)\\]\t+\\[\\([^]]+\\)\\].+") - -(defvar jao-recoll-flags "-A -p 5 -n 100") - -(defvar jao-recoll-single-buffer t) -(defvar-local jao-recoll--last-query nil) -(defvar-local jao-recoll--last-full-query nil) - -(defun jao-recoll-show-query () - (interactive) - (message (concat jao-recoll--last-query "\n" - jao-recoll--last-full-query))) - -(defun jao-recoll-requery () - (interactive) - (jao-recoll jao-recoll--last-query)) - -(defun jao-recoll--buffer (q) - (get-buffer-create (if jao-recoll-single-buffer - "*Recoll*" - (format "*Recoll: '%s'*" q)))) - -;;;###autoload -(defun jao-recoll (&optional prefix-query) - "Performs a query using recoll and shows the results in a buffer -using org mode." - (interactive) - (let* ((query (read-string "Recoll query: " prefix-query)) - (cmd (format "recoll %s -t %s" - jao-recoll-flags (shell-quote-argument query))) - (inhibit-read-only t) - (lnk nil)) - (with-current-buffer (jao-recoll--buffer query) - (recoll-mode) - (delete-region (point-min) (point-max)) - (shell-command cmd t) - (setq jao-recoll--last-query query) - (goto-char (point-min)) - (when (looking-at-p "Recoll query:") - (setq jao-recoll--last-full-query - (string-trim (thing-at-point 'line))) - (let ((kill-whole-line nil)) (kill-line)) - (insert query) - (forward-line 2)) - (open-line 1) - (while (search-forward-regexp jao-recoll--file-regexp nil t) - (setq lnk - (cond ((string= (match-string 1) "application/pdf") - (concat "doc:" - (file-name-nondirectory (match-string 2)))) - ((string= (match-string 1) "message/rfc822") - (concat "message:" (substring (match-string 2) 7))) - (t (match-string 2)))) - (replace-match (format "* [[%s][\\3]] (\\1)" lnk)) - (forward-line) - (when (looking-at-p "SNIPPETS") - (let ((kill-whole-line t)) - (kill-line) - (while (and (not (eobp)) (not (looking-at-p "/SNIPPETS"))) - (if (looking-at "^\\([1-9][0-9]*\\) : ") - (replace-match (format " - [[%s::\\1][\\1]] : " lnk)) - (insert " - ")) - (forward-line 1)) - (unless (eobp) (kill-line))))) - (pop-to-buffer (current-buffer)) - (goto-char (point-min)) - (org-next-visible-heading 1) - (org-overview) - (jao-recoll-show-query)))) - -(define-key recoll-mode-map [?n] 'org-next-link) -(define-key recoll-mode-map [?p] 'org-previous-link) -(define-key recoll-mode-map [?q] 'bury-buffer) -(define-key recoll-mode-map [?r] 'jao-recoll-requery) -(define-key recoll-mode-map [?g] 'jao-recoll-requery) -(define-key recoll-mode-map [?w] 'jao-recoll-show-query) - - -(provide 'jao-recoll) -;;; jao-recoll.el ends here diff --git a/lib/doc/jao-words.el b/lib/doc/jao-words.el new file mode 100644 index 0000000..52e5093 --- /dev/null +++ b/lib/doc/jao-words.el @@ -0,0 +1,77 @@ +;;; jao-words.el --- utilities for word stats -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <mail@jao.io> +;; Keywords: text + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Simple word counting and classification + +;;; Code: + +(defun jao-words--count-words (raw-word-list) + (cl-loop with result = nil + for elt in raw-word-list + do (cl-incf (cdr (or (assoc elt result) + (car (push (cons elt 0) result))))) + finally return (sort result + (lambda (a b) (string< (car a) (car b)))))) + +(defun jao-words--word-lines (buffer word) + (let ((lines nil) + (last-line nil) + (case-fold-search nil) + (rx (format "\\b%s\\b" (regexp-quote word)))) + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (while (and (re-search-forward rx nil t) (< (length lines) 12)) + (let* ((line (line-number-at-pos)) + (d (- line (or last-line line)))) + (when (<= d 10) + (when last-line + (push last-line lines) + (push line lines))) + (setq last-line (line-number-at-pos)))))) + (mapconcat #'number-to-string (nreverse lines) " "))) + +(defun jao-words-show-stats () + (interactive) + (let* ((words (split-string (downcase (buffer-string)) "\\W+" t)) + (word-list (jao-words--count-words words)) + (buffer (current-buffer))) + (with-current-buffer (get-buffer-create "*word-statistics*") + (erase-buffer) + (insert "| word | occurences | lines | + |-----------+------------|--------------------|\n") + (dolist (elt word-list) + (let* ((word (car elt)) + (count (cdr elt)) + (lines (jao-words--word-lines buffer word))) + (insert (format "| %s | %d | %s |\n" word count lines)))) + (org-mode) + (indent-region (point-min) (point-max)) + (goto-char 5) + (forward-line 2) + (org-table-next-field) + (org-table-sort-lines nil ?N))) + (pop-to-buffer "*word-statistics*")) + + +(provide 'jao-words) +;;; jao-words.el ends here diff --git a/lib/eos/jao-afio.el b/lib/eos/jao-afio.el index 306a1d5..b23e6af 100644 --- a/lib/eos/jao-afio.el +++ b/lib/eos/jao-afio.el @@ -1,6 +1,6 @@ ;;; jao-afio.el --- workspaces in just one frame -*- lexical-binding: t; -*- -;; Copyright (C) 2020, 2021, 2022 jao +;; Copyright (C) 2020, 2021, 2022, 2024, 2025, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: frames @@ -18,249 +18,315 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <https://www.gnu.org/licenses/>. -;;; Code: - +;;; initialisation +(require 'multisession) (require 'cl-lib) +(require 'jao-doc-session) +(require 'jao-pdf) + +(defvar jao-afio-use-frames (not window-system)) +(defvar jao-afio-frame-parameters nil) +(defvar jao-afio-persist-configurations nil) (defvar jao-open-doc-fun 'find-file) (defvar jao-afio-mail-function 'gnus) (defvar jao-afio-use-w3m nil) -(defvar jao-afio-notmuch-in-web nil) +(defvar jao-afio-auto-toggle nil) (defvar jao-afio-switch-hook nil) -(defvar jao-afio--configs '(?c ?w ?g ?p ?s)) -(defvar jao-afio--current-config (car jao-afio--configs)) -(defvar jao-afio--locker nil) -(defvar jao-afio-fallback-fun nil) +(defvar jao-afio--configs '(?c ?w ?g ?p ?s ?t)) +(defvar jao-afio--previous-config (car jao-afio--configs)) +(defvar jao-afio--config-names + '((?c . "main") (?s . "scratch") (?g . "mail") + (?p . "docs") (?w . "web") (?t . "chats"))) + +(define-multisession-variable jao-afio-configurations nil) -(defun jao-afio--check-frame-p () - (assoc 'afio (frame-parameters))) +(defmacro jao-afio-add-frame-parameters (name &rest params) + `(add-to-list 'jao-afio-frame-parameters + '(,(if name (format "%s" name) 'def) ,params))) -(defun jao-afio--init (&optional f) +(defun jao-afio--current-wc () + (window-state-get (frame-root-window) t)) + +(defun jao-afio-save-configuration () (interactive) - (when (and (frame-live-p jao-afio--locker) - (not (eql f jao-afio--locker))) - (if jao-afio-fallback-fun - (funcall jao-afio-fallback-fun) - (error "Another frame is using afio"))) - (setq jao-afio--locker f) - (modify-frame-parameters f '((afio . t))) - (setq jao-afio--current-config ?c) - (mapc (lambda (r) (set-register r nil)) jao-afio--configs) - (window-configuration-to-register ?c)) - -(defun jao-afio--steal () + (when-let* ((c (jao-afio--current-config))) + (setf (alist-get c (multisession-value jao-afio-configurations)) + (jao-afio--current-wc)) + (message "Configuration of %s saved" (jao-afio-frame-name c)))) + +(defun jao-afio-restore-configuration (c) + (when-let* ((_ jao-afio-persist-configurations) + (c (alist-get c (multisession-value jao-afio-configurations)))) + (window-state-put c) + t)) + +(defun jao-afio--current-config (&optional c f) + (when c (modify-frame-parameters f `((afio . ,c)))) + (frame-parameter f 'afio)) + +(defun jao-afio--set-up-frame (cfg) + (when jao-afio-use-frames + (let ((fn (jao-afio-frame-name cfg))) + (set-frame-name fn) + (when-let* ((params (cadr (or (assoc fn jao-afio-frame-parameters) + (assoc 'def jao-afio-frame-parameters))))) + (modify-frame-parameters nil params))))) + +(defun jao-afio--init (&optional _f) (interactive) - (setq jao-afio--locker nil) - (jao-afio--init (window-frame (get-buffer-window (current-buffer))))) + (jao-afio--current-config ?c) + (if jao-afio-use-frames + (jao-afio--set-up-frame ?c) + (window-configuration-to-register ?c))) (defun jao-afio--check-frame () - (unless (jao-afio--check-frame-p) - (or ;; (when jao-afio-fallback-fun - ;; (funcall jao-afio-fallback-fun) - ;; t) - (when (y-or-n-p "Another frame is using afio. Steal? ") - (jao-afio--steal) - t) - (error "Aborted")))) - -(defun jao-afio--next-frame () - (interactive) - (jao-afio--check-frame) - (let* ((cur (member jao-afio--current-config jao-afio--configs)) - (next (or (cadr cur) (car jao-afio--configs)))) - (jao-afio--goto-frame next))) + (unless (jao-afio--current-config) + (jao-afio--init (window-frame (get-buffer-window (current-buffer)))))) +(defvar jao-afio-side-buffers '("*eldoc*")) + +;;; utilities +(defun jao-afio-trisect (&optional force) + (interactive) + (let ((fw (frame-width)) + (display-buffer-alist nil)) + (cond ((or force (>= fw 240)) + (let ((b (current-buffer))) + (delete-other-windows) + (switch-to-buffer (other-buffer b)) + (split-window-horizontally) + (switch-to-buffer (other-buffer b)) + (split-window-horizontally) + (switch-to-buffer b) + (balance-windows) + (when-let* ((b (seq-keep #'get-buffer jao-afio-side-buffers))) + (other-window -1) + (switch-to-buffer (car b)) + (other-window 1)))) + ((> fw 162) + (delete-other-windows) + (split-window-horizontally) + (switch-to-buffer (other-buffer)))))) + +;;; session openers ;;;###autoload -(defun jao-afio-open-pdf-session () +(defun jao-afio-open-pdf-session (&optional docs) (interactive) - (let ((jao-doc-view-inhibit-session-save t)) - (dolist (doc (jao-doc-view-session)) - (when (and (file-exists-p doc) (y-or-n-p (format "Open %s? " doc))) - (jao-open-doc doc) - (other-window 1))) - (other-window 1))) + (dolist (doc (or docs (jao-doc-session))) + (when (and (stringp doc) (file-exists-p doc)) + (if (jao-pdf-is-pdf-file doc) (funcall jao-open-doc-fun doc) (find-file doc)) + (other-window 1))) + (other-window 1)) + +(defvar jao-afio-left-width nil) (defun jao-afio-open-doc () (interactive) (delete-other-windows) - (split-window-right) - (let ((docs (cl-remove-if-not (lambda (b) - (with-current-buffer b (jao-doc-view--is-doc))) - (buffer-list)))) + (split-window-right jao-afio-left-width) + (let ((docs (cl-remove-if-not 'jao-doc-session-is-doc (buffer-list)))) (if (car docs) (progn (switch-to-buffer (car docs)) (switch-to-buffer-other-window (or (cadr docs) (car docs)))) - (when (and (jao-doc-view-session) (y-or-n-p "Load saved session? ")) - (jao-afio-open-pdf-session))))) + (when-let* ((docs (jao-doc-session))) + (when (y-or-n-p (format "Load saved session? (%d docs)" (length docs))) + (jao-afio-open-pdf-session docs)))))) + +(declare-function w3m "w3m") +(declare-function notmuch "notmuch") +(declare-function jao-eww-session-eww-buffers "jao-eww-session") +(declare-function jao-eww-session-load "jao-eww-session") -(declare w3m "w3m") -(declare w3m-alive-p "w3m") -(declare w3m-previous-buffer "w3m") -(declare notmuch "notmuch") +(defun jao-afio--open-eww-session () + (if-let* ((b (jao-eww-session-eww-buffers))) + (switch-to-buffer (car b)) + (jao-eww-session-load))) + +;;;###autoload +(defun jao-afio-org-agenda () + (interactive) + (org-agenda nil "j") + (when-let* ((w (get-buffer-window "*Org Agenda*"))) + (set-window-margins w 2 1) + (with-current-buffer (window-buffer w) + (setq-local cursor-in-non-selected-windows nil + line-spacing 0.2)))) ;;;###autoload (defun jao-afio-open-www () (interactive) (require 'jao-eww-session) (if (< (frame-width) 160) - (if jao-afio-use-w3m (w3m) (jao-eww-session-load)) - (delete-other-windows) - (split-window-right) + (if jao-afio-use-w3m (w3m) (jao-afio--open-eww-session)) (if jao-afio-use-w3m - (w3m) - (jao-eww-session-load) + (progn (delete-other-windows) + (split-window-right) + (w3m)) + (jao-afio-trisect) + (jao-afio--open-eww-session) (let ((b (current-buffer))) (other-window 1) - (if jao-afio-notmuch-in-web - (notmuch) - (switch-to-buffer (car (jao-eww-session--list-buffers b)))) + (switch-to-buffer (car (jao-eww-session-eww-buffers b))) + (other-window 1) + (switch-to-buffer (car (jao-eww-session-eww-buffers b))) (other-window 1))))) ;;;###autoload (defun jao-afio-open-gnus () (interactive) - (delete-other-windows) - (org-agenda-list) + (jao-afio-org-agenda) (calendar) (find-file (expand-file-name "inbox.org" org-directory)) + (delete-other-windows) (gnus) - (jao-gnus--set-summary-line)) + ;; (jao-gnus--set-summary-line) + ) (defun jao-afio--mail-sidebar () (other-window 1) (delete-other-windows-vertically) (find-file (expand-file-name "inbox.org" org-directory)) + (set-window-dedicated-p nil t) (split-window-below (/ (window-height) 3)) (other-window 1) - (org-agenda-list) - (split-window-below -9) + (jao-afio-org-agenda) + (set-window-dedicated-p nil t) + (split-window-below -8) (other-window 1) (switch-to-buffer "*Calendar*") + (set-window-dedicated-p nil t) (other-window 1)) +(defvar jao-afio-mail-sidebar-width 60) +(defvar jao-afio-mail-sidebar-right nil) + +(defun jao-afio--open-mail (fun) + (unless (get-buffer "*Calendar*") (calendar)) + (delete-other-windows) + (if (< (frame-width) 160) + (funcall fun) + (let ((w (+ 3 jao-afio-mail-sidebar-width))) + (if jao-afio-mail-sidebar-right + (split-window-horizontally (- w)) + (split-window-horizontally w) + (other-window 1))) + (funcall fun) + ;; (set-window-dedicated-p nil t) + (jao-afio--mail-sidebar))) + ;;;###autoload -(defun jao-afio-open-notmuch () +(defun jao-afio-open-mail () (interactive) - (delete-other-windows) - (split-window-horizontally -80) - (notmuch) - (jao-afio--mail-sidebar)) + (cond ((eq 'gnus jao-afio-mail-function) (jao-afio-open-gnus)) + ((eq 'notmuch jao-afio-mail-function) (jao-afio--open-mail 'notmuch)) + (t (jao-afio-trisect)))) -(defun jao-afio-open-mail-function () +;;;###autoload +(defun jao-afio-toggle-mail-sidebar () (interactive) - (jao-trisect) - (other-window 2) - (delete-window) - (other-window 1) - (funcall jao-afio-mail-function) - (jao-afio--mail-sidebar)) + (setq jao-afio-mail-sidebar-right (not jao-afio-mail-sidebar-right)) + (jao-afio-open-mail)) ;;;###autoload -(defun jao-afio-open-mail () +(defun jao-afio-reset () (interactive) - (unless (get-buffer "*Calendar*") (calendar)) - (cond ((eq 'gnus jao-afio-mail-function) (jao-afio-open-gnus)) - ((eq 'notmuch jao-afio-mail-function) (jao-afio-open-notmuch)) - (jao-afio-open-mail-function (jao-afio-open-mail-function)))) + (let ((c (jao-afio--current-config))) + (unless (jao-afio-restore-configuration c) + (delete-other-windows) + (cl-case c + (?w (jao-afio-open-www)) + (?g (jao-afio-open-mail)) + (?p (jao-afio-open-doc)) + (t (jao-afio-trisect))) + (when jao-afio-persist-configurations (jao-afio-save-configuration))))) + +;;; go to frame +(defsubst jao-afio--find-frame (c) + (seq-find (lambda (f) (eq (jao-afio--current-config nil f) c)) (frame-list))) + +(defun jao-afio-frame-name (&optional c) + (alist-get (or c (jao-afio--current-config)) jao-afio--config-names)) + +(defun jao-afio-frame-no (&optional c) + (alist-get (or c (jao-afio--current-config)) + '((?s . 0) (?c . 1) (?g . 2) (?w . 3) (?p . 4) (?t . 5)))) (defun jao-afio--goto-frame (next &optional reset) - (when (or reset (not (eq next jao-afio--current-config))) - (let ((next-cfg (when (not reset) (get-register next)))) - (window-configuration-to-register jao-afio--current-config) - (setq jao-afio--current-config next) - (if next-cfg - (jump-to-register next) - (delete-other-windows) - (cl-case next - (?w (jao-afio-open-www)) - (?g (jao-afio-open-mail)) - (?p (jao-afio-open-doc)) - (?s (delete-other-windows)))) + (jao-afio--check-frame) + (let ((current (jao-afio--current-config))) + (if (and jao-afio-auto-toggle + (eq next current) + (not reset) + (not (eq current jao-afio--previous-config))) + (jao-afio--goto-frame jao-afio--previous-config) + (when (or reset (not (eq next current))) + (if jao-afio-use-frames + (let ((f (jao-afio--find-frame next))) + (select-frame-set-input-focus (or f (make-frame))) + (when (setq reset (or reset (not f))) + (jao-afio--set-up-frame next))) + (window-configuration-to-register (jao-afio--current-config)) + (when (and (not reset) (get-register next)) + (ignore-errors (jump-to-register next))) + (setq reset (or reset (not (get-register next))))) + (jao-afio--current-config next) + (unless (eq current next) (setq jao-afio--previous-config current)) + (when reset (jao-afio-reset))) (run-hooks 'jao-afio-switch-hook)))) -(defun jao-afio--goto-main (&optional reset) +(defun jao-afio-goto-main (&optional reset) (interactive "P") - (jao-afio--check-frame) (jao-afio--goto-frame ?c reset)) -(defun jao-afio--goto-scratch (&optional reset) +(defun jao-afio-goto-mail (&optional reset) (interactive "P") - (jao-afio--check-frame) - (jao-afio--goto-frame ?s reset)) - -(defun jao-afio--goto-mail (&optional reset) - (interactive "P") - (jao-afio--check-frame) (jao-afio--goto-frame ?g reset)) -(defun jao-afio--goto-docs (&optional reset) +(defun jao-afio-goto-docs (&optional reset) (interactive "P") - (jao-afio--check-frame) (jao-afio--goto-frame ?p reset)) -(defun jao-afio--goto-www (&optional reset) +(defun jao-afio-goto-www (&optional reset) (interactive "P") - (if (jao-afio--check-frame-p) - (jao-afio--goto-frame ?w reset) - (when (and jao-afio-use-w3m (w3m-alive-p)) - (pop-to-buffer (w3m-alive-p))))) - -(defun jao-afio--try-init (&optional f) - (ignore-errors (jao-afio--init f)) - t) - -(defun jao-afio--goto-www-buffer (buf &rest _) - (jao-afio--goto-www) - (jao-first-window) - (switch-to-buffer buf nil t)) - -(defun jao-afio--goto-pdf-buffer (buf &rest _) - (if (jao-afio--check-frame-p) - (progn (jao-afio--goto-docs) - (jao-first-window) - (switch-to-buffer buf nil t)) - (pop-to-buffer buf))) + (jao-afio--goto-frame ?w reset)) + +(defun jao-afio-toggle () + (interactive) + (jao-afio--goto-frame jao-afio--previous-config)) (defun jao-afio-goto-scratch (&optional one-win) - (jao-afio--goto-scratch) + (interactive "P") + (jao-afio--goto-frame ?s one-win) (when one-win (delete-other-windows))) -(defun jao-afio-current-frame () - (cl-case jao-afio--current-config - (?c "Main") - (?s "Scratch") - (?g "Mail") - (?p "Docs") - (?w "Web"))) - -(defun jao-afio-current-no () - (cl-case jao-afio--current-config - (?c "1") - (?s "0") - (?g "2") - (?p "4") - (?w "3"))) +(defun jao-afio-goto-chats (&optional reset) + (interactive "P") + (jao-afio--goto-frame ?t reset)) ;;;###autoload (defun jao-afio-goto-nth (n) (cl-case n - ((1) (jao-afio--goto-main)) - ((2) (jao-afio--goto-mail)) - ((3) (jao-afio--goto-www)) - ((4) (jao-afio--goto-docs)) - ((5) (jao-afio--goto-scratch-1)) - ((0) (jao-afio--goto-scratch)))) + ((-1) (jao-afio-goto-scratch t)) + ((0) (jao-afio-goto-scratch)) + ((1) (jao-afio-goto-main)) + ((2) (jao-afio-goto-mail)) + ((3) (jao-afio-goto-www)) + ((4) (jao-afio-goto-docs)) + ((5) (jao-afio-goto-chats)))) + +;;;###autoload +(defun jao-afio-pop-to-buffer (n buff) + (interactive "NFrame number: \nBBuffer: ") + (jao-afio-goto-nth n) + (pop-to-buffer buff)) +;;; setup ;;;###autoload -(defun jao-afio-setup (&optional fallback-fun init-p) - (global-set-key "\C-cf" 'jao-afio--goto-main) - (global-set-key "\C-cg" 'jao-afio--goto-mail) - (global-set-key "\C-cw" 'jao-afio--goto-www) - (global-set-key "\C-cz" 'jao-afio--goto-docs) - (setq jao-afio-fallback-fun fallback-fun) - (add-hook (if init-p 'after-init-hook 'after-make-frame-functions) - 'jao-afio--try-init)) +(defun jao-afio-setup (&optional use-frames) + (setq jao-afio-use-frames use-frames) + (jao-afio--init)) (provide 'jao-afio) ;;; jao-afio.el ends here diff --git a/lib/eos/jao-buffers.el b/lib/eos/jao-buffers.el new file mode 100644 index 0000000..7bc3431 --- /dev/null +++ b/lib/eos/jao-buffers.el @@ -0,0 +1,77 @@ +;;; jao-buffers.el --- deal with buffers and windows -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <mail@jao.io> +;; Keywords: files + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Code: + +;;;; attached buffers +(defun jao-display-buffer-below-selected (buffer alist) + (delete-other-windows-vertically) + (display-buffer-below-selected buffer alist)) + +(defun jao-display-below-eldoc (buffer alist) + (let ((w (selected-window))) + (pop-to-buffer "*eldoc*" nil t) + (jao-display-buffer-below-selected buffer alist) + (select-window w t))) + +(defun jao-attached-buffer-entry (name-rx height) + `(,name-rx (display-buffer-reuse-window + jao-display-buffer-below-selected) + (window-height . ,(or height 25)))) + +;;;###autoload +(defun jao-attach-below-eldoc (rx &optional h) + (add-to-list 'display-buffer-alist + `(,rx + (display-buffer-reuse-window jao-display-below-eldoc) + (height . (or ,h 0.5))))) + +;;;###autoload +(defmacro jao-with-attached-buffer (name-rx height &rest body) + (declare (indent defun)) + `(let ((display-buffer-alist '(,(jao-attached-buffer-entry name-rx height)))) + ,@body)) + +;;;###autoload +(defun jao-define-attached-buffer (name-rx &optional height) + (add-to-list 'display-buffer-alist + (jao-attached-buffer-entry name-rx height))) + +;;;; same mode +;;;###autoload +(defun jao-buffer-same-mode (&optional mode pre-fn switch-fn) + (interactive) + (let* ((mode (or mode major-mode)) + (modes (if (symbolp mode) (list mode) mode)) + (pred `(lambda (b) + (let ((b (get-buffer (if (consp b) (car b) b)))) + (member (buffer-local-value 'major-mode b) + ',modes)))) + (buff (read-buffer "Buffer: " nil t pred))) + (when pre-fn (funcall pre-fn)) + (if switch-fn (funcall switch-fn buff) (switch-to-buffer buff)))) + +;;;###autoload +(defun jao-buffer-same-mode-cmd (&optional pop) + (interactive "P") + (jao-buffer-same-mode nil nil (and pop #'pop-to-buffer))) + +(provide 'jao-buffers) +;;; jao-buffers.el ends here diff --git a/lib/eos/jao-dirmon.el b/lib/eos/jao-dirmon.el index 4fb8609..261433d 100644 --- a/lib/eos/jao-dirmon.el +++ b/lib/eos/jao-dirmon.el @@ -1,6 +1,6 @@ ;;; jao-dirmon.el --- little utility to monitor disk usage -*- lexical-binding: t; -*- -;; Copyright (C) 2022 jao +;; Copyright (C) 2022, 2024, 2025, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: tools @@ -25,21 +25,47 @@ ;;; Code: (require 'multisession) +(require 'view) (require 'jao-shell) (define-multisession-variable jao-dirmon-last '()) +(defvar jao-dirmon-roots '("/var/local" "~")) + (defun jao-dirmon-dirs () - (jao-shell-cmd-lines "find ~ -mindepth 2 -maxdepth 3 -type d")) + (mapcan (lambda (d) + (jao-shell-cmd-lines + (format "find %s -mindepth 2 -maxdepth 3 -type d" d))) + jao-dirmon-roots)) (defun jao-dirmon-sizes () (mapcar (lambda (f) - (let ((x (split-string (jao-shell-string "du -s" f)))) + (let ((x (split-string (jao-shell-string "du -BM -s" f)))) (cons (cadr x) (string-to-number (car x))))) (jao-dirmon-dirs))) -(defvar jao-dirmon-threshold 100000) +(defvar jao-dirmon-threshold 100) (defvar jao-dirmon-last-delta nil) +(defvar jao-dirmon-buffer "*jao-dirmon") + +(defun jao-dirmon--show-deltas (old current deltas) + (with-current-buffer (get-buffer-create jao-dirmon-buffer) + (view-mode -1) + (delete-region (point-min) (point-max)) + (insert "High deltas since " (car old) "\n\n") + (dolist (d (seq-sort-by #'cdr #'> deltas)) + (insert (format "- %s: %s Mb\n" (car d) (cdr d)))) + (insert "\n\nSizeable dirs\n\n") + (let ((threshold (* 10 jao-dirmon-threshold))) + (dolist (c (seq-take-while (lambda (x) (> (cdr x) threshold)) + (seq-sort-by #'cdr #'> current))) + (insert (format "- %s: %s Mb\n" (car c) (cdr c))))) + (goto-char (point-min)) + (view-mode 1) + (pop-to-buffer (current-buffer) nil t) + (when (y-or-n-p "Save current state?") + (setf (multisession-value jao-dirmon-last) + (cons (current-time-string) current))))) ;;;###autoload (defun jao-dirmon-report () @@ -49,12 +75,10 @@ (high ())) (dolist (c current) (let ((d (- (cdr c) (alist-get (car c) old 0 nil #'string=)))) - (when (> d jao-dirmon-threshold) - (push c high)))) + (when (> (abs d) jao-dirmon-threshold) + (push (cons (car c) d) high)))) (setq jao-dirmon-last-delta high) - (let ((prompt (format"High deltas: %s. Save state?" high))) - (when (y-or-n-p prompt) - (setf (multisession-value jao-dirmon-last) current))) + (jao-dirmon--show-deltas old current jao-dirmon-last-delta) jao-dirmon-last-delta)) (provide 'jao-dirmon) diff --git a/lib/eos/jao-ednc.el b/lib/eos/jao-ednc.el deleted file mode 100644 index 5750ea7..0000000 --- a/lib/eos/jao-ednc.el +++ /dev/null @@ -1,143 +0,0 @@ -;;; jao-ednc.el --- Minibuffer notifications using EDNC -*- lexical-binding: t; -*- - -;; Copyright (C) 2020, 2021 jao - -;; Author: jao <mail@jao.io> -;; Keywords: tools, abbrev - -;; 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 <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Use the ednc package to provide a notification daemon that uses -;; the minibuffer to display them. - -;;; Code: - -(require 'ednc) -(require 'jao-minibuffer) - -(declare-function tracking-add-buffer "tracking") -(declare-function tracking-remove-buffer "tracking") - -(defvar jao-ednc--count-format " {%d} ") -(defvar jao-ednc--notifications ()) -(defvar jao-ednc--handlers ()) - -(defvar jao-ednc-use-tracking nil) - -(defface jao-ednc-tracking '((t :inherit warning)) - "Tracking notifications face" - :group 'jao-ednc) - -(defun jao-ednc--last-notification () (car jao-ednc--notifications)) - -(defun jao-ednc--format-last () - (when (jao-ednc--last-notification) - (let ((s (ednc-format-notification (jao-ednc--last-notification) t))) - (replace-regexp-in-string "\n" " " (substring-no-properties s))))) - -(defun jao-ednc--count () - (let ((no (length jao-ednc--notifications))) - (if (> no 0) - (propertize (format jao-ednc--count-format no) 'face 'warning) - ""))) - -(defun jao-ednc-add-handler (app handler) - (add-to-list 'jao-ednc--handlers (cons app handler))) - -(defun jao-ednc-ignore-app (app) - (jao-ednc-add-handler app - (lambda (not _) - (ignore-errors (ednc-dismiss-notification not))))) - -(defun jao-ednc--clean (&optional notification) - (tracking-remove-buffer (get-buffer ednc-log-name)) - (if notification - (remove notification jao-ednc--notifications) - (pop jao-ednc--notifications)) - (jao-minibuffer-refresh)) - -(defun jao-ednc--show-last () - (message (jao-ednc--format-last))) - -(defun jao-ednc--default-handler (notification newp) - (if (not newp) - (jao-ednc--clean notification) - (when jao-ednc-use-tracking - (tracking-add-buffer (get-buffer ednc-log-name) '(jao-ednc-tracking))) - (push notification jao-ednc--notifications) - (jao-ednc--show-last))) - -(defun jao-ednc--handler (notification) - (alist-get (ednc-notification-app-name notification) - jao-ednc--handlers - #'jao-ednc--default-handler - nil - 'string=)) - -(defun jao-ednc--on-notify (old new) - (when old (funcall (jao-ednc--handler old) old nil)) - (when new (funcall (jao-ednc--handler new) new t))) - -;;;###autoload -(defun jao-ednc-setup (minibuffer-order) - (setq jao-notify-use-messages-p t) - (with-eval-after-load "tracking" - (when jao-ednc-use-tracking - (add-to-list 'tracking-faces-priorities 'jao-ednc-tracking) - (when (listp tracking-shorten-modes) - (add-to-list 'tracking-shorten-modes 'ednc-view-mode)))) - (when minibuffer-order - (jao-minibuffer-add-variable '(jao-ednc--count) minibuffer-order)) - (add-hook 'ednc-notification-presentation-functions #'jao-ednc--on-notify) - (ednc-mode)) - -;;;###autoload -(defun jao-ednc-pop () - (interactive) - (pop-to-buffer-same-window ednc-log-name)) - -;;;###autoload -(defun jao-ednc-show () - (interactive) - (if (not (jao-ednc--last-notification)) - (jao-ednc-pop) - (jao-ednc--show-last))) - -;;;###autoload -(defun jao-ednc-invoke-last-action () - (interactive) - (if (jao-ednc--last-notification) - (ednc-invoke-action (jao-ednc--last-notification)) - (message "No active notifications")) - (jao-ednc--clean)) - -;;;###autoload -(defun jao-ednc-dismiss () - (interactive) - (when (jao-ednc--last-notification) - (ignore-errors - (with-current-buffer ednc-log-name - (ednc-dismiss-notification (jao-ednc--last-notification))))) - (jao-ednc--clean)) - -;;;###autoload -(defun jao-ednc-dismiss-all () - (interactive) - (while (jao-ednc--last-notification) - (jao-ednc-dismiss))) - -(provide 'jao-ednc) -;;; jao-ednc.el ends here diff --git a/lib/eos/jao-eshell-here.el b/lib/eos/jao-eshell-here.el index cf29e31..8733cb9 100644 --- a/lib/eos/jao-eshell-here.el +++ b/lib/eos/jao-eshell-here.el @@ -1,6 +1,6 @@ ;;; jao-eshell-here.el --- Easy opening of eshell buffers -*- lexical-binding: t; -*- -;; Copyright (C) 2021 jao +;; Copyright (C) 2021, 2023, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: eshell @@ -25,6 +25,11 @@ ;;; Code: (require 'eshell) +(require 'esh-mode) +(require 'em-dirs) +(require 'jao-buffers) +(require 'project) + (defvar jao-eshell-here-display-buffer-alist '(("^\\*eshell" @@ -33,8 +38,8 @@ "Value to use for `display-buffer-alist' when displaying the eshell buffer.") (defun jao-eshell-here--find-window (b) - (when-let (w (seq-find (lambda (w) (eq (window-buffer w) b)) - (window-list))) + (when-let* ((w (seq-find (lambda (w) (eq (window-buffer w) b)) + (window-list)))) (select-window w))) (defun jao-eshell-here--frame-buffer (&optional b) @@ -64,7 +69,7 @@ C-u) open in the current's buffer default dir." (jao-with-attached-buffer "^\\*eshell" 0.5 (if (buffer-live-p b) (progn (pop-to-buffer b nil t) - (eshell-save-some-history) + ;; (eshell-save-some-history) (when dir (jao-eshell--cd-here dir))) (let ((default-directory (or dir default-directory))) (eshell (when force-new 4))) @@ -75,7 +80,7 @@ C-u) open in the current's buffer default dir." (when (derived-mode-p 'eshell-mode) (when (fboundp 'eshell-autojump-save) (eshell-autojump-save)) - (eshell-save-some-history) + ;; (eshell-save-some-history) (if (> (frame-height) (window-height)) (delete-window) (bury-buffer)))) diff --git a/lib/eos/jao-mac.el b/lib/eos/jao-mac.el new file mode 100644 index 0000000..2312c6c --- /dev/null +++ b/lib/eos/jao-mac.el @@ -0,0 +1,269 @@ +;;; jao-mac.el --- Running applescript. -*- lexical-binding: t; -*- + +;; Copyright (C) 2025, 2026 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <mail@jao.io> +;; Keywords: lisp + +;; 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 <https://www.gnu.org/licenses/>. + +(require 'thingatpt) +(require 'jao-shell) + +;;; applescript +(defun jao-mac-applescript-prepare (&rest lines) + (let ((script (mapconcat 'identity lines "\r")) + (start)) + (while (string-match "\n" script) + (setq script (replace-match "\r" t t script))) + (while (string-match "'" script start) + (setq start (+ 2 (match-beginning 0)) + script (replace-match "\\'" t t script))) + script)) + +(defun jao-mac-run-applescript (script) + (string-trim (shell-command-to-string (format "osascript -e '%s'" script)))) + +(defun jao-mac-run-applescript* (&rest lines) + (jao-mac-run-applescript (apply #'jao-mac-applescript-prepare lines))) + +(defun jao-mac-tell-app (app &rest script-lines) + (let* ((app-id (string-split app)) + (id (if (> (length app-id) 1) (car app-id) "")) + (app (if (> (length app-id) 1) (cadr app-id) (car app-id))) + (pre (list (format "tell application %s %S" id app))) + (post '("end tell\n"))) + (apply #'jao-mac-run-applescript* (append pre script-lines post)))) + +;;; open + +;;;###autoload +(defun jao-mac-open (thing &rest args) + "Invoke open after formatting thing with args, using `format'" + (jao-shell-exec (format "open %s" (apply #'format thing args)))) + +;;; notifications + +(defun jao-mac-notify (title subtitle msg) + (jao-mac-run-applescript* + (format "display notification %S with title %S subtitle %S" + msg title subtitle))) + +(defun jao-mac-app-badge (app) + "A very hacky, yet efficient, way of getting and apps badge." + (let* ((c (format "lsappinfo info -app %S -only StatusLabel" app)) + (s (shell-command-to-string c))) + (when (string-match ".*=\"\\([0-9]+\\)\" ." s) + (string-to-number (match-string 1 s)))) ) + +;;; Preview + +(declare-function 'doc-view-current-page "doc-view") + +;; https://alvinalexander.com/macos/applescript-how-to-open-pdf-file-in-preview-go-to-page/ +;; This will work as long as Preview is the default app for the file at hand. +;;;###autoload +(defun jao-mac-open-in-preview (&optional file page _height) + (interactive) + (let ((file (if file (expand-file-name file) (buffer-file-name))) + (page (or page (and (derived-mode-p 'doc-view-doc) + (doc-view-current-page))))) + (jao-mac-run-applescript* + (format "tell application id \"com.apple.Preview\" to open (POSIX file %S)\r\r" + (file-truename file)) + "delay 1" + "tell application \"System Events\"" + "keystroke \"g\" using {option down, command down}" + (format "keystroke %s" (or page 1)) + "delay 0.1\rkeystroke return\rend tell"))) + + +;;; Dict + +(defvar jao-mac-dict-history nil) + +(defun jao-mac-dict (&optional word) + (interactive (list (thing-at-point 'word))) + (jao-mac-open "dict://%S" + (read-string (format "Look up (%s): " word) + nil + 'jao-mac-dict-history + (substring-no-properties word) + t))) + +;;; Skim +(defvar jao-skim--current-file-script + (jao-mac-applescript-prepare + "tell application \"Skim\"" + " try" + " set theD to front document" + " set theP to (path of theD)" + " set thePg to (get index of current page of theD)" + " return (theP & \"::\" & thePg)" + " on error" + " return \"\"" + " end try" + "end tell")) + +(defun jao-skim-current-doc () + "Returns a list of path and page number for the current Skim doc." + (when-let* ((p (jao-mac-run-applescript jao-skim--current-file-script)) + (p (and (not (string-blank-p p)) p))) + (let ((ps (split-string p "::"))) + (list (car ps) (string-to-number (cadr ps)))))) + +(defun jao-skim-open-current-doc () + (interactive) + (when-let* ((ps (jao-skim-current-doc))) + (apply 'jao-open-doc ps))) + +(defvar jao-skim--current-page-text + (jao-mac-applescript-prepare + "tell application \"Skim\"" + "return the text of the current page of the front document" + "end tell")) + +(defun jao-skim-page-text () + (jao-mac-run-applescript jao-skim--current-page-text)) + +;;;###autoload +(defun jao-skim-view-page-text () + (interactive) + (when-let* ((ps (jao-skim-current-doc)) + (p (car ps)) + (n (cadr ps)) + (txt (jao-skim-page-text)) + (bn (format "*%s - %s - txt*" p n))) + (with-current-buffer (get-buffer-create bn) + (delete-region (point-min) (point-max)) + (insert txt) + (pop-to-buffer (current-buffer))))) + +(defun jao-pdf-skim-org-link (title) + (when-let* ((fp (jao-skim-current-doc)) + (file (file-name-nondirectory (car fp))) + (page (cadr fp)) + (lnk (format "doc:%s::%s" file page))) + (org-link-make-string lnk title))) + +;;;###autoload +(defun jao-mac-open-in-skim (&optional file page _height) + (interactive) + (let* ((file (if file (expand-file-name file) (buffer-file-name))) + (page (or page (and (derived-mode-p 'doc-view-mode) + (doc-view-current-page))))) + (jao-mac-open "skim://%s%s" file (if page (format "#page=%s" page) "")))) + +;;;###autoload +(defun jao-pdf-insert-skim-org-link () + (interactive) + (if-let* ((title (read-string "Title: ")) + (lnk (jao-pdf-skim-org-link title))) + (insert lnk) + (user-error "Skim is not viewing any docs!"))) + +;;; NetNewsWire + +(defvar jao-nnw--current-article-script + (jao-mac-applescript-prepare + "tell application \"NetNewsWire\"" + "try" + "return (the url of the current article)" + "on error" + "return \"\"" + "end try" + "end tell")) + +(defun jao-nnw-current-article () + "The URL of the current article in NetNewsWire" + (jao-mac-run-applescript jao-nnw--current-article-script)) + +(defun jao-nnw-browse-current-article () + "Browse the URL of the current NNW article." + (interactive) + (if-let* ((url (jao-nnw-current-article))) + (unless (string-empty-p url) + (browse-url url)) + (message "No article selected in NetNewsWire"))) + +(defvar jao-nnw--label-cmd + "lsappinfo info -app NetNewsWire -only StatusLabel") + +(defun jao-nnw-unread-count () + (jao-mac-app-badge "NetNewsWire")) + +(defun jao-mac-open-nnw () + (interactive) + (jao-mac-open "-a NetNewsWire")) + +;;; Safari +(defun jao-safari-current-url () + (jao-mac-tell-app "Safari" "return URL of current tab of window 1")) + +(defun jao-safari-browse-current () + "Browse the URL of the current Safari topmost document." + (interactive) + (browse-url (jao-safari-current-url))) + +;;; Firefox +(defvar jao-ffox--current-url-script + (jao-mac-applescript-prepare + "tell application \"Firefox\"" + " activate" + " delay 0.15" + " tell application \"System Events\"" + " keystroke \"l\" using command down" + " delay 0.20" + " keystroke \"c\" using command down" + " end tell" + " delay 0.5" + "end tell" + "return the clipboard")) + +(defun jao-firefox-current-url () + (let ((res (jao-mac-run-applescript jao-ffox--current-url-script))) + (jao-mac-run-applescript "tell application \"Emacs\" to activate") + res)) + +(defun jao-firefox-open () + (interactive) + (jao-mac-open "-a Firefox")) + +;;; DevonThink + +;; (defun jao-devon-tell (&rest script-lines) +;; (apply #'jao-mac-tell-app "id DNtp" script-lines )) + +;; (defun jao-devon-find-url (file) +;; (jao-devon-tell +;; "repeat with db in databases" +;; (format "set res to lookup records with path %S in db" +;; (file-truename file)) +;; "if res /= {} then return the reference URL of (item 1 of res)" +;; "end repeat" +;; "return \"\"")) + +;; (defun jao-devon-show-search (s) +;; (jao-devon-tell (format "show search %S" s) "activate")) + +;; (defun jao-devon-open (file &optional page height) +;; (let ((url (jao-devon-find-url file))) +;; (if (string-empty-p (or url "")) +;; (let ((jao-pdf-open-in-emacs t)) +;; (jao-find-or-open file page height)) +;; (let ((p (if page (format "?page=%s" (- page 1)) ""))) +;; (jao-mac-open "%s%s" url p))))) + +(provide 'jao-mac) +;;; jao-mac.el ends here diff --git a/lib/eos/jao-minibuffer.el b/lib/eos/jao-minibuffer.el index bdafa74..8f8996e 100644 --- a/lib/eos/jao-minibuffer.el +++ b/lib/eos/jao-minibuffer.el @@ -1,6 +1,6 @@ ;;; jao-minibuffer.el --- using the minibuffer to report status -*- lexical-binding: t; -*- -;; Copyright (C) 2020, 2021, 2022 jao +;; Copyright (C) 2020, 2021, 2022, 2024, 2025, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: extensions @@ -27,67 +27,89 @@ (defvar jao-minibuffer-info ()) (defvar jao-minibuffer-msg-info '("")) (defvar jao-minibuffer-align-right t) -(defvar jao-minibuffer-right-margin (if window-system 0 2)) +(defvar jao-minibuffer-adaptive-alignment t) +(defvar jao-minibuffer-right-margin (if window-system 0 1)) (defvar jao-minibuffer-maximized-frames-p t) (defvar jao-minibuffer-frame-width nil) (defvar jao-minibuffer-active-buffer-line-color "azure4") (defvar jao-minibuffer-inactive-buffer-line-color "grey25") +(defvar jao-minibuffer-inhibit nil) +(defvar jao-minibuffer-info-face 'default) +(defvar jao-minibuffer-info-face-alt 'default) (defconst jao-minibuffer--name " *Minibuf-0*") (defun jao-minibuffer--trim (s w) (if (< (string-width (or s "")) w) (format (format "%%%ds" (if jao-minibuffer-align-right w (- w))) s) - (substring s 0 w))) + (substring s 0 (min w (string-width s))))) (defun jao-minibuffer--width () (cond ((numberp jao-minibuffer-frame-width) jao-minibuffer-frame-width) (jao-minibuffer-maximized-frames-p (frame-width)) (t (min (frame-width) (window-width (minibuffer-window)))))) -(defun jao-minibuffer--format-info (&optional info) - (let* ((info (or info jao-minibuffer-info)) - (info (if jao-minibuffer-align-right info (reverse info)))) - (mapconcat #'string-trim - (seq-remove #'string-blank-p (mapcar 'format-mode-line info)) - " "))) +(defun jao-minibuffer--format-info (&optional info alt-p) + (let* ((face (if alt-p jao-minibuffer-info-face-alt jao-minibuffer-info-face)) + (info (or info jao-minibuffer-info)) + (info (if jao-minibuffer-align-right info (reverse info))) + (info (seq-remove #'string-blank-p (mapcar 'format-mode-line info)))) + (propertize (mapconcat #'string-trim info " ") 'face face))) (defun jao-minibuffer--aligned (w) (let* ((msg (jao-minibuffer--format-info)) (msg (cond (jao-minibuffer-align-right (string-trim msg)) (t (string-trim-left msg))))) (unless (string-empty-p msg) - (let ((msg (propertize msg :minibuffer-message t)) + (let ((msg (propertize msg 'minibuffer-message t)) (w (- (jao-minibuffer--width) w jao-minibuffer-right-margin))) (if (> w 0) (jao-minibuffer--trim msg w) ""))))) (defun jao-minibuffer--insert (msg) - (let ((hack (derived-mode-p 'pdf-view-mode 'doc-view-mode))) - (with-current-buffer jao-minibuffer--name - (delete-region (point-min) (point-max)) - (insert msg) - (when hack (other-window 1) (other-window -1))))) + (with-current-buffer jao-minibuffer--name + (delete-region (point-min) (point-max)) + (insert msg))) (defun jao-minibuffer--strip-prev (msg) - (if-let ((n (text-property-any 0 (length msg) :minibuffer-message t msg))) + (if-let* ((n (text-property-any 0 (length msg) 'minibuffer-message t msg))) (string-trim (substring msg 0 n)) msg)) (defun jao-minibuffer--prefix (msgs) - (when-let (p (string-join (butlast msgs) "\n")) + (when-let* ((p (string-join (butlast msgs) "\n"))) (unless (string-blank-p p) (concat p "\n")))) (defun jao-minibuffer--format-msg (msg) - (let* ((msgs (mapcar #'jao-minibuffer--strip-prev (split-string msg "\n"))) - (prefix (jao-minibuffer--prefix msgs)) - (msg (car (last msgs))) + (let* ((msgs (mapcar #'jao-minibuffer--strip-prev (split-string msg "\n" t))) + (msgs + (seq-remove (lambda (s) (get-text-property 0 'invisible s)) msgs)) + (prefix (if msgs (jao-minibuffer--prefix msgs) "")) + (msg (or (car (last msgs)) "")) (w (string-width msg))) (if jao-minibuffer-align-right (concat prefix msg (jao-minibuffer--aligned w)) (concat prefix (jao-minibuffer--aligned (+ 3 w)) " " msg)))) (defun jao-minibuffer--set-message (msg) - (when jao-minibuffer-mode (jao-minibuffer--format-msg (or msg "")))) + (when jao-minibuffer-mode + (or (and (string= jao-minibuffer--name (or (buffer-name) "")) msg) + jao-minibuffer-inhibit + (and (not jao-minibuffer-msg-info) msg) + (let* ((info (jao-minibuffer--format-info jao-minibuffer-msg-info t)) + (sep (if (string-blank-p (or msg "")) "" " - ")) + (pref (let ((len (+ (string-width info) (string-width sep)))) + (format (format "\n%%%ds" len) ""))) + (msg (if (and msg pref) + (replace-regexp-in-string "\n" pref msg) + msg)) + (left (if jao-minibuffer-align-right info (or msg ""))) + (right (if jao-minibuffer-align-right (or msg "") info)) + (msg (or (if info (format "%s%s%s" left sep right) msg) ""))) + (if cursor-in-echo-area msg (jao-minibuffer--format-msg msg)))))) + +(defun jao-minibuffer--clear-message () + (let ((jao-minibuffer-inhibit nil)) + (or (jao-minibuffer--insert (jao-minibuffer--set-message nil)) t))) (setq set-message-function #'jao-minibuffer--set-message) @@ -96,35 +118,38 @@ (set list-name (remove v (symbol-value list-name))) (add-to-ordered-list list-name v order))) -;;;###autoload +(defun jao-minibuffer--adjust-alignment (&rest _) + (when jao-minibuffer-adaptive-alignment + (setq jao-minibuffer-align-right + (< (or (car (window-absolute-pixel-edges)) 0) + (/ (or (cadr (assoc 'outer-size (frame-geometry))) 0) 2)))) + (jao-minibuffer-refresh)) + (defun jao-minibuffer-add-variable (variable-name &optional order) (jao-minibuffer--add-variable 'jao-minibuffer-info variable-name order)) -;;;###autoload (defun jao-minibuffer-add-msg-variable (variable-name &optional order) (jao-minibuffer--add-variable 'jao-minibuffer-msg-info variable-name order)) -;;;###autoload (defun jao-minibuffer-remove-variable (variable-name) (let ((v `(:eval ,variable-name))) (setq jao-minibuffer-info (remove v jao-minibuffer-info)) - (setq jao-minibuffer-msg-info (remove v jao-minibuffer-info)))) + (setq jao-minibuffer-msg-info (remove v jao-minibuffer-msg-info)))) -;;;###autoload (define-minor-mode jao-minibuffer-mode "Show minibuffer status" :global t :lighter "" :group 'jao (if jao-minibuffer-mode - (progn (advice-add 'select-window :after #'jao-minibuffer-refresh) - (advice-add 'force-mode-line-update :after #'jao-minibuffer-refresh) - (setq clear-message-function #'jao-minibuffer-refresh) - (jao-minibuffer-refresh)) + (progn ;; (advice-add 'select-window :after #'jao-minibuffer-refresh) + (advice-add 'select-window :after #'jao-minibuffer--adjust-alignment) + (advice-add 'force-mode-line-update :after #'jao-minibuffer-refresh) + (setq clear-message-function #'jao-minibuffer--clear-message) + (jao-minibuffer-refresh)) (advice-remove 'select-window #'jao-minibuffer-refresh) (advice-remove 'force-mode-line-update #'jao-minibuffer-refresh) (setq clear-message-function nil) (jao-minibuffer--insert ""))) -;;;###autoload (defun jao-minibuffer-refresh (&rest _ignore) (interactive) (when jao-minibuffer-mode @@ -133,5 +158,30 @@ (jao-minibuffer--format-info jao-minibuffer-msg-info)))) (jao-minibuffer--insert (jao-minibuffer--format-msg (or msg "")))))) +(defun jao-minibuffer-toggle-adaptive-alignment () + (interactive) + (setq jao-minibuffer-adaptive-alignment + (not jao-minibuffer-adaptive-alignment)) + (jao-minibuffer-refresh)) + +(define-minor-mode jao-minibuffer-mode-line-mode + "Show info in mode line instead of minibuffer" + :global t :lighter "" :group 'jao + (let ((e '(" " (:eval jao-minibuffer-info)))) + (if jao-minibuffer-mode-line-mode + (add-to-list 'global-mode-string e) + (setq global-mode-string (delete e global-mode-string))))) + +(defvar jao-minibuffer--title-format nil) + +(define-minor-mode jao-minibuffer-frame-title-mode + "Show info in frame title instead of minibuffer" + :global t :lighter "" :group 'jao + (when (not jao-minibuffer--title-format) + (setq jao-minibuffer--title-format frame-title-format)) + (if jao-minibuffer-frame-title-mode + (setq frame-title-format '("emacs - " (:eval jao-minibuffer-info))) + (setq frame-title-format jao-minibuffer--title-format))) + (provide 'jao-minibuffer) ;;; jao-minibuffer.el ends here diff --git a/lib/eos/jao-mode-line.el b/lib/eos/jao-mode-line.el index 0fd5a2e..d3388e4 100644 --- a/lib/eos/jao-mode-line.el +++ b/lib/eos/jao-mode-line.el @@ -1,6 +1,6 @@ ;;; jao-mode-line.el --- mode-line info -*- lexical-binding: t; -*- -;; Copyright (C) 2022 jao +;; Copyright (C) 2022, 2025 jao ;; Author: jao <mail@jao.io> ;; Keywords: convenience @@ -31,7 +31,7 @@ ;;;; mode line toggle (defun jao-mode-line--face-height (face &optional all) (let* ((h (face-attribute face :height (window-frame))) - (nh (if (eq 'unspecified h) 1 'unspecified))) + (nh (if (eq 'unspecified h) 10 'unspecified))) (set-face-attribute face (when (not all) (window-frame)) :height nh))) (defun jao-mode-line--set-inactive-face (x frame) @@ -41,21 +41,28 @@ ;;;###autoload (defun jao-mode-line-toggle (&optional all) (interactive "P") - (jao-mode-line--face-height 'mode-line all)) + (jao-mode-line--face-height 'mode-line-active all)) ;;;###autoload (defun jao-mode-line-toggle-inactive (&optional all) (interactive "P") (jao-mode-line--face-height 'mode-line-inactive all)) +(defun jao-mode-line--old-str () + (thread-first (format-mode-line jao-mode-line--old-format) + (substring-no-properties) + (string-trim))) + ;;;###autoload (defun jao-mode-line-echo () (interactive) - (message "%s" (format-mode-line mode-line-format))) + (message "%s" (jao-mode-line--old-str)) + (setq-local header-line-format + (if header-line-format nil jao-mode-line--old-format))) ;;;###autoload (defun jao-mode-line-hide-inactive (frame) - (jao-mode-line--set-inactive-face 1 frame)) + (jao-mode-line--set-inactive-face 10 frame)) ;;;###autoload (defun jao-mode-line-show-inactive (frame) @@ -78,8 +85,6 @@ 'gnus-article-mode 'gnus-summary-mode) mode-line-buffer-identification) - ((derived-mode-p 'circe-channel-mode) - (format "%s [%d]" (buffer-name) (length (circe-channel-nicks)))) ((not (null eww-data)) (or (plist-get eww-data :title) "No title")) (t "%b")))) @@ -101,7 +106,7 @@ ;;;; mode line in minibuffer -(defvar jao-mode-line--old-format nil) +(defvar jao-mode-line--old-format mode-line-format) (defvar jao-mode-line--face nil) (defvar jao-mode-line--inactive-face nil) (defvar jao-mode-line--props @@ -120,32 +125,52 @@ (if inactive jao-mode-line--inactive-face jao-mode-line--face))) (defun jao-mode-line-adjust-faces () - (let ((bg (frame-parameter nil 'background-color))) + (interactive) + (let ((bg (and (display-graphic-p) + (frame-parameter nil 'background-color))) + (ol (and (display-graphic-p) jao-minibuffer-active-buffer-line-color)) + (ul (and (display-graphic-p) + jao-minibuffer-inactive-buffer-line-color))) (jao-mode-line--extract-face nil) (jao-mode-line--extract-face t) - (set-face-attribute 'mode-line nil :box nil :height 1 + (set-face-attribute 'mode-line-active nil :box nil :height 10 :background bg :foreground bg - :overline jao-minibuffer-active-buffer-line-color - :underline jao-minibuffer-inactive-buffer-line-color - :extend t) - (set-face-attribute 'mode-line-inactive nil :box nil :height 1 + :overline ol :underline ul :extend t) + (set-face-attribute 'mode-line-inactive nil :box nil :height 10 :background bg :foreground bg ;; :overline bg - :underline jao-minibuffer-inactive-buffer-line-color - :extend t))) + :underline ul :extend t))) -;;;###autoload -(defun jao-mode-line-add-to-minibuffer (&optional order) +(defun jao-mode-line--maybe-refresh () + (when (mode-line-window-selected-p) (jao-minibuffer-refresh))) + +(defconst jao-mode-line--hidden-format + '("" (:eval (jao-mode-line--maybe-refresh)))) + +(defun jao-mode-line--add-to-minibuffer (order msg-p) (interactive) (setq jao-mode-line--old-format mode-line-format) - (setq-default mode-line-format '(" ")) + (setq-default mode-line-format jao-mode-line--hidden-format) (setq-default mode-line-position jao-mode-line--position) (dolist (b (buffer-list)) - (with-current-buffer b (setq-local mode-line-format '(" ")))) - (jao-minibuffer-add-variable 'jao-mode-line--format (or order 90)) + (with-current-buffer b + (setq-local mode-line-format jao-mode-line--hidden-format))) + (if msg-p + (jao-minibuffer-add-msg-variable '(jao-mode-line--old-str) (or order 90)) + (jao-minibuffer-add-variable 'jao-mode-line--format (or order 90))) (jao-mode-line-adjust-faces)) ;;;###autoload +(defun jao-mode-line-add-to-minibuffer-right (&optional order) + (interactive) + (jao-mode-line--add-to-minibuffer order nil)) + +;;;###autoload +(defun jao-mode-line-add-to-minibuffer-left (&optional order) + (interactive) + (jao-mode-line--add-to-minibuffer order t)) + +;;;###autoload (defun jao-mode-line-remove-from-minibuffer () (interactive) (jao-mode-line--revert-face nil) @@ -154,7 +179,8 @@ (dolist (b (buffer-list)) (with-current-buffer b (setq-local mode-line-format jao-mode-line--old-format))) - (jao-minibuffer-remove-variable 'jao-mode-line--format)) + (jao-minibuffer-remove-variable 'jao-mode-line--format) + (jao-minibuffer-remove-variable '(jao-mode-line--old-str))) (provide 'jao-mode-line) diff --git a/lib/eos/jao-notify.el b/lib/eos/jao-notify.el index a3ea474..c1efb58 100644 --- a/lib/eos/jao-notify.el +++ b/lib/eos/jao-notify.el @@ -1,6 +1,6 @@ -;; jao-notify.el -- Interacting with notification daemon +;; jao-notify.el -- Interacting with notification daemon -*- lexical-binding: t; -*- -;; Copyright (c) 2017, 2019, 2020, 2021 Jose Antonio Ortega Ruiz +;; Copyright (c) 2017, 2019, 2020, 2021, 2024, 2025, 2026 Jose Antonio Ortega Ruiz ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> ;; Start date: Sun Jan 08, 2017 20:24 @@ -12,26 +12,35 @@ ;;; Code: -(defvar jao-notify-use-messages-p nil) +(defvar jao-notify-use-messages nil) (defvar jao-notify-timeout 5000) -(defvar jao-notify-audio-icon (jao-data-file "music-player-icon.png")) +(defvar jao-notify-audio-icon nil) (declare-function notifications-notify "notifications") +(declare-function alert "alert") +(declare-function jao-mac-notify "jao-mac") ;; "/usr/share/icons/Papirus/64x64/mimetypes/audio-x-generic.svg" ;; "/usr/share/icons/Tango/scalable/mimetypes/audio-x-generic.svg" -(defun jao-notify (msg &optional title icon) +(defun jao-notify (msg &optional title icon subtitle) (let ((title (when (and title (not (string-blank-p title))) title))) - (if jao-notify-use-messages-p - (message "%s%s%s" (or title "") (if title ": " "") (or msg "")) - (let* ((args `(:timeout ,jao-notify-timeout)) - (args (append args - (if title `(:title ,title :body ,msg) `(:title ,msg)))) - (args (if (and (stringp icon) (file-exists-p icon)) - (append args `(:app-icon ,(format "%s" icon))) - args))) - (apply 'notifications-notify args))))) + (cond ((eq jao-notify-use-messages t) + (message "%s%s%s" (or title "") (if title ": " "") (or msg ""))) + ((eq jao-notify-use-messages 'notification) + (let* ((args `(:timeout ,jao-notify-timeout)) + (args (append args + (if title + `(:title ,title :body ,msg) + `(:title ,msg)))) + (args (if (and (stringp icon) (file-exists-p icon)) + (append args `(:app-icon ,(format "%s" icon))) + args))) + (apply 'notifications-notify args))) + ((eq jao-notify-use-messages 'alert) + (alert msg :title title :icon icon :never-persist t)) + ((eq jao-notify-use-messages 'mac) + (jao-mac-notify title subtitle msg))))) (provide 'jao-notify) diff --git a/lib/eos/jao-shell.el b/lib/eos/jao-shell.el index ff1c160..e13e07f 100644 --- a/lib/eos/jao-shell.el +++ b/lib/eos/jao-shell.el @@ -1,6 +1,6 @@ ;;; jao-shell.el --- shell utils -*- lexical-binding: t; -*- -;; Copyright (C) 2022 jao +;; Copyright (C) 2022, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: shell @@ -24,25 +24,29 @@ ;;; Code: -(defun jao-shell--quote (x) (shell-quote-argument (format "%s" x))) - -;;;###autoload (defun jao-shell-cmd-lines (cmd &rest args) - (let ((cmd (concat cmd " " (mapconcat #'jao-shell--quote args " ")))) + (let ((cmd (concat cmd " " (combine-and-quote-strings args)))) (split-string (shell-command-to-string cmd) "\n" t))) -;;;###autoload (defun jao-shell-string (cmd &rest args) (string-trim (or (car (apply #'jao-shell-cmd-lines cmd args)) ""))) -;;;###autoload -(defun jao-shell-exec (command) +(defun jao-shell-exec (command &optional wait) (interactive (list (read-shell-command "$ " (if current-prefix-arg (cons (concat " " (buffer-file-name)) 0) "")))) - (start-process-shell-command command nil command)) + (if wait + (call-process-shell-command command) + (start-process-shell-command command nil command))) + +(defun jao-shell-exec* (command-or-wait &rest args) + (let ((wait (and (not (stringp command-or-wait)) command-or-wait)) + (args (if (stringp command-or-wait) (cons command-or-wait args) args))) + (jao-shell-exec (combine-and-quote-strings args) wait))) + +(defun jao-shell-exec-p (command) (eq 0 (jao-shell-exec command t))) (defmacro jao-shell-def-exec (name &rest args) `(defun ,name (&rest other-args) @@ -52,9 +56,14 @@ "*jao-exec - console*" (string-join (append (list ,@args) other-args) " ")))) -;;;###autoload -(defun jao-shell-running-p (pr) - (not (string-blank-p (shell-command-to-string (concat "pidof " pr))))) +(defun jao-shell-output (cmd handler) + (with-temp-buffer + (call-process-shell-command cmd nil (current-buffer)) + (goto-char (point-min)) + (funcall handler))) + +(defun jao-shell-running-p (pr) (eq 0 (jao-shell-exec* t "pidof" pr))) +(defun jao-shell-kill-p (pr) (eq 0 (jao-shell-exec* t "killall" pr))) (provide 'jao-shell) ;;; jao-shell.el ends here diff --git a/lib/eos/jao-sleep.el b/lib/eos/jao-sleep.el index 93da0e7..3b46031 100644 --- a/lib/eos/jao-sleep.el +++ b/lib/eos/jao-sleep.el @@ -1,6 +1,6 @@ ;;; jao-sleep.el --- Actions upon sleep/awake -*- lexical-binding: t; -*- -;; Copyright (C) 2020 jao +;; Copyright (C) 2020, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: hardware @@ -25,7 +25,7 @@ (defvar jao-sleep-sleep-functions nil) (defvar jao-sleep-awake-functions nil) -(defvar jao-sleep--dbus-registration-object nil) +(defvar jao-sleep--dbus-sleep-registration-object nil) (defun jao-sleep--dbus-sleep-handler (sleep-start) (condition-case nil @@ -41,12 +41,12 @@ "Register actions to take on sleep and on awake, using the system D-BUS." (when (featurep 'dbusbind) (setq jao-sleep--dbus-sleep-registration-object - (dbus-register-signal (if session-dbus :session :system) - "org.freedesktop.login1" - "/org/freedesktop/login1" - "org.freedesktop.login1.Manager" - "PrepareForSleep" - #'jao-sleep--dbus-sleep-handler)))) + (dbus-register-signal (if session-dbus :session :system) + "org.freedesktop.login1" + "/org/freedesktop/login1" + "org.freedesktop.login1.Manager" + "PrepareForSleep" + #'jao-sleep--dbus-sleep-handler)))) ;;;###autoload (defun jao-sleep-dbus-unregister () diff --git a/lib/themes/jao-themes.el b/lib/eos/jao-themes.el index 2c182f6..a1d22c1 100644 --- a/lib/themes/jao-themes.el +++ b/lib/eos/jao-themes.el @@ -19,10 +19,17 @@ ;;; Code: (require 'ansi-color) +(require 'cl) ;;; palette -(defvar jao-themes-default-face "Hack-9") -(defvar jao-themes--face-family "Hack") +(defvar jao-themes-default-face nil) +(defvar jao-themes-default-family "Hack") +(defvar jao-themes-default-variable-pitch-size 9) +(defvar jao-themes-default-variable-pitch-family "Hack") +(defvar jao-themes-default-size 9) +(defvar jao-themes--face-family jao-themes-default-face) +(defvar jao-themes--variable-pitch-family nil) +(defvar jao-themes--variable-pitch-height nil) (defvar jao-themes--fg "black") (defvar jao-themes--bg "white") (defvar jao-themes--box "grey75") @@ -62,6 +69,10 @@ (defvar jao-themes--f11 '((c "cadetblue4"))) (defvar jao-themes--f12 '((c "darkslategrey"))) +(defgroup jao-themes-faces nil + "Faces for unified custom themes" + :group 'faces) + (defface jao-themes-hilite '((t :inherit default)) "") (defface jao-themes-italic '((t :inherit default)) "") (defface jao-themes-button '((t :inherit default)) "") @@ -112,6 +123,10 @@ (jao-themes--normalize-body (apply 'append (mapcar 'jao-themes--parse-face-sym f)))))) +(defsubst jao--put-face (str face) + (put-text-property 0 (length str) 'face face str) + str) + (defvar jao-themes--default-cidxs '("#000000" "#cd0000" "#00cd00" "#cdcd00" "#0000cd" "#cd00cd" "#00cdcd" "#e5e5e5" @@ -191,6 +206,8 @@ (nth clr jao-themes--default-cidxs) (format "color-%s" clr))) ((and (symbolp clr) (cadr (assoc clr *jao-themes--color-names*)))) + ((equal clr 'dfg) jao-themes--fg) + ((equal clr 'dbg) jao-themes--bg) (t 'unspecified))) (defun jao-themes--parse-face-sym (s) @@ -300,7 +317,8 @@ (jao-themes-f10 (p f10)) (jao-themes-f11 (p f11)) (jao-themes-f12 (p f12))) - `((ansi-color-bright-blue (c "steelblue3" "steelblue3")) + `((ansi-color-bold bf) + (ansi-color-bright-blue (c "steelblue3" "steelblue3")) (ansi-color-bright-cyan (c "cyan3" "cyan3")) (ansi-color-bright-green (c "darkseagreen3" "darkseagreen3")) (ansi-color-bright-magenta (c "lightpink4" "lightpink4")) @@ -311,27 +329,13 @@ (ansi-color-green (c "darkseagreen4" "darkseagreen4")) (ansi-color-magenta (c "lightpink3" "lightpink3")) (ansi-color-yellow (c "lightgoldenrod3" "lightgoldenrod3")) - (aw-background-face (p dimm)) - (aw-leading-char-face (~ error) bf :height 3.0) - (awesome-tray-module-awesome-tab-face (p f00)) - (awesome-tray-module-battery-face (p f00)) - (awesome-tray-module-battery-face (p f00)) - (awesome-tray-module-buffer-name-face (p f11)) - (awesome-tray-module-circe-face (p f00)) - (awesome-tray-module-date-face (p f00)) - (awesome-tray-module-date-face (p f01)) - (awesome-tray-module-evil-face (p f00)) - (awesome-tray-module-file-path-face (p f00)) - (awesome-tray-module-git-face (p f10)) - (awesome-tray-module-last-command-face (p f00)) - (awesome-tray-module-location-face (p f00)) - (awesome-tray-module-mode-name-face (p f00)) - (awesome-tray-module-parent-dir-face (p f00)) - (awesome-tray-module-rvm-face (p f00))) + (avy-lead-face (c "red" "grey90") bf :height 1.0) + (avy-lead-face-0 (~ avy-lead-face) bf) + (avy-lead-face-1 (~ avy-lead-face))) `((bbdb-company) - (bbdb-field-name bf) + (bbdb-field-name (p f00)) (bbdb-field-value (~ default)) - (bbdb-name ul) + (bbdb-name (p f01)) (bmk-mgr-bookmark-face (~ default)) (bmk-mgr-folder-face bf) (bmk-mgr-sel-bookmark-face link) @@ -505,6 +509,10 @@ (embark-verbose-indicator-documentation it) (embark-verbose-indicator-title (p f00)) (embark-verbose-indicator-shadowed (p dimm)) + (ement-room-reactions-key (~ ement-room-reactions)) + (ement-room-self-face (p warning) nb) + (ement-room-timestamp-header (~ header-line) :height 1.0 nb) + (ement-room-user-face (~ default)) (emms-browser-album-face (p f00) :height 1.0) (emms-browser-artist-face (p f01) :height 1.0) (emms-browser-composer-face (p f02) :height 1.0) @@ -604,6 +612,11 @@ (font-lock-type-face (p type)) (font-lock-variable-name-face (p variable-name)) (font-lock-warning-face (p warning)) + (forge-pullreq-merged (p dimm)) + (forge-pullreq-open (c nil nil)) + (forge-pullreq-rejected (~ forge-pullreq-merged) st) + (forge-topic-pending (c nil nil)) + (forge-topic-unread (p f00)) (forge-topic-label bx) (fringe (p dimm)) (fuel-font-lock-debug-error (p error) nul) @@ -816,7 +829,7 @@ (lui-button-face (p link)) (lui-highlight-face (p warning)) (lui-time-stamp-face (p dimm)) - (lui-track-bar (p dimm) :height 0.2 nul nil ex)) + (lui-track-bar (p dimm) nul nil ex)) `((magit-branch (p f00)) (magit-cherry-equivalent (p warning)) (magit-diff-add (~ diff-added)) @@ -837,6 +850,7 @@ (magit-log-head-label-tags (p warning) nbf) (magit-log-graph (p f11)) (magit-log-tag-label (p keyword)) + (magit-process-ok (c nil nil)) (magit-section-highlight (p hilite) ex) (magit-section-heading (~ outline-1)) (magit-section-secondary-heading (~ outline-2)) @@ -940,7 +954,7 @@ (org-ellipsis (p dimm)) (org-formula (p f02)) (org-headline-done (p dimm)) - (org-hide (c dbg dfg)) + (org-hide (c dbg nil)) (org-latex-and-export-specials (~ default)) (org-level-1 (~ outline-1)) (org-level-2 (~ outline-2)) @@ -963,7 +977,7 @@ (org-table (p f01)) (org-tag (p dimm) nbf) (org-target ul) - (org-time-grid dfg dbg) + (org-time-grid (p dimm)) (org-todo nbf niv (p error)) (org-upcoming-deadline (p f02)) (org-verbatim (p hilite)) @@ -976,14 +990,14 @@ (outline-6 nbf ul (p outline-6)) (outline-7 nbf ul (p outline-7)) (outline-8 nbf ul (p outline-8)) - (outline-minor-1 bf (~ outline-1) (c nil "grey95") ex) - (outline-minor-2 bf (~ outline-2) (c nil "grey95") ex) - (outline-minor-3 bf (~ outline-3) (c nil "grey95") ex) - (outline-minor-4 bf (~ outline-4) (c nil "grey95") ex) - (outline-minor-5 bf (~ outline-5) (c nil "grey95") ex) - (outline-minor-6 bf (~ outline-6) (c nil "grey95") ex) - (outline-minor-7 bf (~ outline-7) (c nil "grey95") ex) - (outline-minor-8 bf (~ outline-8) (c nil "grey95") ex)) + (outline-minor-1 nbf (~ outline-1) ex) + (outline-minor-2 nbf (~ outline-2) ex) + (outline-minor-3 nbf (~ outline-3) ex) + (outline-minor-4 nbf (~ outline-4) ex) + (outline-minor-5 nbf (~ outline-5) ex) + (outline-minor-6 nbf (~ outline-6) ex) + (outline-minor-7 nbf (~ outline-7) ex) + (outline-minor-8 nbf (~ outline-8) ex)) `((powerline-active1 (~ mode-line)) (powerline-active2 (~ mode-line-inactive)) (powerline-inactive1 (~ mode-line-inactive)) @@ -1016,6 +1030,7 @@ (rst-level-8-face (~ outline-8))) `((secondary-selection (p hilite) ex) (separator-line (~ default) (st "grey85")) + (sh-heredoc (~ font-lock-doc-face)) (sh-quoted-exec (p f00)) (shortdoc-heading (p outline-1) nul) (shortdoc-section (p outline-2)) @@ -1080,25 +1095,37 @@ (success (p success)) (sunshine-forecast-date-face (~ default)) (sunshine-forecast-day-divider-face (p dimm)) - (sunshine-forecast-headline-face (~ header-line))) - `((telega-button (~ button)) + (sunshine-forecast-headline-face (~ header-line)) + (symbol-overlay-face-1 (c nil "brown1")) + (symbol-overlay-face-2 (c nil "lightsalmon1")) + (symbol-overlay-face-3 (c nil "tomato1")) + (symbol-overlay-face-4 (c nil "coral")) + (symbol-overlay-face-5 (~ symbol-overlay-face-1)) + (symbol-overlay-face-6 (~ symbol-overlay-face-2)) + (symbol-overlay-face-7 (~ symbol-overlay-face-3)) + (symbol-overlay-face-8 (~ symbol-overlay-face-4))) + `((tab-bar (~ header-line)) + (telega-button (~ button)) (telega-button-active (~ button)) + (telega-entity-type-spoiler (c dfg dbg)) (telega-msg-heading (p f00)) (telega-msg-self-title (p f01)) (telega-root-heading (p hilite)) (textsec-suspicious (~ default) bx) - (term (~ default)) + (term (c dfg dbg)) (tool-bar (~ default)) (tooltip :family ,jao-themes--face-family (c nil "lightyellow") :height 0.9) (trailing-whitespace (p error)) + (transient-key-exit (p error) bf) + (transient-key-stay (p f00) bf) (treemacs-root-face nul bf :scale 1.1) (twittering-timeline-footer-face (~ header-line)) (twittering-timeline-header-face (~ header-line)) (twittering-uri-face (~ link)) (twittering-username-face (p f01))) `((underline ul)) - `((variable-pitch :family ,jao-themes--face-family) + `((variable-pitch :family ,jao-themes--variable-pitch-family) (variable-pitch-text (~ variable-pitch)) (vertical-border (c ,jao-themes--box nil) :inherit default) (vertico-current (p hilite)) @@ -1181,7 +1208,7 @@ (push df fs))))) (defun jao-themes--adjust-palette (p s) - (if-let (v (alist-get s p)) (cons (cons s (car v)) (assoc-delete-all s p)) p)) + (if-let* ((v (alist-get s p))) (cons (cons s (car v)) (assoc-delete-all s p)) p)) (defun jao-themes--let-palette (palette) (let ((palette (seq-reduce #'jao-themes--adjust-palette '(fg bg box) palette))) @@ -1213,25 +1240,37 @@ (cons kind f-alist) (assq-delete-all kind window-system-default-frame-alist))))) +;;;###autoload (defmacro jao-define-custom-theme (name &rest args) (let ((palette (cdr (assoc :palette args))) (x-faces (cdr (assoc :x-faces args))) (x-colors (cdr (assoc :x-colors args))) - (family (cadr (assoc :face-family args))) - (size (or (cadr (assoc :face-size args)) 9)) + (family (or (cadr (assoc :face-family args)) + jao-themes-default-family)) + (size (or (cadr (assoc :face-size args)) + jao-themes-default-size)) + (vpitch (or (cadr (assoc :variable-pitch-family args)) + jao-themes-default-variable-pitch-family)) + (vsize (or (cadr (assoc :variable-pitch-size args)) + jao-themes-default-variable-pitch-size)) (bw (or (cadr (assoc :bold-weight args)) jao-themes--bold-weight))) `(progn (custom-make-theme-feature ',name) (deftheme ,name) (custom-theme-set-variables ',name '(jao-themes-default-face - (format "%s-%s" ,family ,size)) + ,(format "%s-%s" family size)) '(jao-themes--face-family ,family) + '(jao-themes--variable-pitch-family + ,vpitch) + '(jao-themes--variable-pitch-height + ,(* 10 vsize)) '(jao-themes--bold-weight ,bw)) (let ((*jao-themes--color-names* ',(cdr (assoc :names args))) (jao-themes--face-family ,family)) (let* ,(jao-themes--let-palette palette) (jao-themes--set-fbg 'x) + (jao-themes--set-fbg 'ns) (jao-themes--set-fbg 'pgtk) (let* ((xfaces (jao-themes--make-faces ',x-faces ',x-colors)) (tx-faces (jao-themes--extract-faces xfaces xfaces))) diff --git a/lib/eos/jao-tracking.el b/lib/eos/jao-tracking.el index 520116d..4cf80c1 100644 --- a/lib/eos/jao-tracking.el +++ b/lib/eos/jao-tracking.el @@ -1,6 +1,6 @@ -;;; jao-minibuffer-tracking.el --- Tracking notifications in minibuffer -*- lexical-binding: t; -*- +;; jao-minibuffer-tracking.el --- Tracking notifications -*- lexical-binding: t; -*- -;; Copyright (C) 2021 jao +;; Copyright (C) 2021, 2022, 2024, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: convenience @@ -18,33 +18,33 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <https://www.gnu.org/licenses/>. -;;; Code: +;;; require (require 'tracking) (require 'shorten) (require 'jao-minibuffer) +(require 'jao-afio) - -;; shorten +;;; shorten +;;;###autoload (defun jao-shorten-modes (&rest modes) (dolist (m modes) (add-to-list 'tracking-shorten-modes m))) -(defun jao-tracking--clean-slack (s) - (let* ((s (replace-regexp-in-string - "^\\*Slack - .*? : \\(mpdm-\\)?\\([^ ]+\\)\\( \\(T\\)\\)?.*" - "#\\2\\4" - s)) - (s (replace-regexp-in-string "logstash-\\([^-]+\\)-\\(.+\\)" - "\\2-\\1" - s))) - (replace-regexp-in-string "^[^a-zA-Z#]+" "#" s))) +(defvar jao-tracking-cleaners '(("^[^a-zA-Z#@]+" . "#"))) + +;;;###autoload +(defun jao-tracking-cleaner (rx subst) + (add-to-list 'jao-tracking-cleaners (cons rx subst))) (defun jao-tracking-shorten-aggressively (lst tail-count) - (let* ((s (shorten-join-sans-tail lst tail-count))) + (let ((s (shorten-join-sans-tail lst tail-count))) (if (string-match-p "^#" s) (substring s 1 nil) s))) (defun jao-tracking-split-clean (s) - (shorten-split (jao-tracking--clean-slack s))) + (dolist (cln jao-tracking-cleaners) + (when (string-match (car cln) s) + (setq s (replace-match (cdr cln) nil nil s)))) + (shorten-split s)) (defun jao-tracking-shorten (old-func &rest args) (let ((shorten-join-function #'jao-tracking-shorten-aggressively) @@ -53,14 +53,15 @@ (advice-add #'tracking-shorten :around #'jao-tracking-shorten) - -;; additional highlighting +;;; additional highlighting (defvar jao-tracking-highlight-rx "$^") +;;;###autoload (defun jao-tracking-faces (&rest faces) (dolist (face faces) (add-to-list 'tracking-faces-priorities face))) +;;;###autoload (defun jao-tracking-add-buffer (old-func &rest args) (let* ((buffer (car args)) (faces (if (and buffer @@ -73,8 +74,7 @@ (advice-add 'tracking-add-buffer :around #'jao-tracking-add-buffer) (jao-tracking-faces 'lui-highlight-face) - -;; minibuffer +;;; minibuffer (defvar jao-tracking-string "") (defvar jao-tracking-bkg "grey93") @@ -84,18 +84,28 @@ `((t :foreground ,jao-tracking-bkg :background ,jao-tracking-bkg)) "" :group 'faces) -(defun jao-tracking-set-log (v) - (when (member window-system '(x)) - (x-change-window-property "_EMACS_LOG" v nil nil nil nil 0))) +(defvar jao-tracking--pipe + (let ((name "/tmp/emacs.status")) + (unless (file-exists-p name) + (shell-command (format "mkfifo %s" name))) + name)) -(jao-tracking-set-log "") +(defun jao-tracking-set-log (v) + (when (fboundp 'x-change-window-property) + (x-change-window-property "_EMACS_LOG" v nil nil nil nil 0)) + (if (bound-and-true-p jao-wayland-enabled) + (let ((inhibit-message t)) + (shell-command (format "echo \"%s\" > %s" v jao-tracking--pipe))) + (let* ((action (if (string-blank-p v) "remove" "add")) + (cmd (format "wmctrl -r emacs -b %s,demands_attention" action))) + (shell-command-to-string cmd)))) (defun jao-tracking--buffer-str (s) (if (listp s) `(:propertize ,(plist-get s :propertize) face (jao-tracking-minibuffer - ,@(when-let ((f (plist-get s 'face))) + ,@(when-let* ((f (plist-get s 'face))) (jao-tracking-set-log " * ") (list f)))) `(:propertize "|" face jao-tracking-minibuffer-sep))) @@ -114,10 +124,59 @@ (setq jao-tracking-string (jao-tracking-build-str new-val)) (jao-minibuffer-refresh)) -(jao-minibuffer-add-variable 'jao-tracking-string -10) -(add-variable-watcher 'tracking-mode-line-buffers #'jao-tracking-echo) -;; since we're using the minibuffer, forget the mode line -(advice-add #'tracking-mode :override (lambda (&optional _) (interactive))) +(defvar jao-tracking-use-scratch 5) +(defvar jao-tracking--start-frame nil) + +(defun jao-tracking--remove-visible-buffers () + (unless (and jao-afio-use-frames jao-tracking-use-scratch) + (tracking-remove-visible-buffers))) + +;;; package setup +;;;###autoload +(defun jao-tracking-go-to-chats () + (interactive) + (when jao-tracking-use-scratch + (jao-afio-goto-nth jao-tracking-use-scratch))) + +;;;###autoload +(defun jao-tracking-next-buffer () + (interactive) + (if jao-tracking-use-scratch + (let ((k (if (numberp jao-tracking-use-scratch) jao-tracking-use-scratch 0)) + (n (jao-afio-frame-no))) + (unless (eq k n) (setq jao-tracking--start-frame n)) + (cond (tracking-buffers + (let ((bs tracking-buffers)) + (if (eq k n) + (tracking-next-buffer) + (jao-afio-goto-nth k) + (when (and (car bs) (not (memq (current-buffer) bs))) + (pop-to-buffer (car bs))) + (tracking-remove-visible-buffers)))) + (jao-tracking--start-frame + (jao-afio-goto-nth jao-tracking--start-frame) + (setq jao-tracking--start-frame nil)))) + (tracking-next-buffer)) + (jao-tracking-update-minibuffer)) + +(defun jao-tracking-add-to-minibuffer () + (interactive) + (jao-minibuffer-add-variable 'jao-tracking-string -10) + (add-variable-watcher 'tracking-mode-line-buffers #'jao-tracking-echo) + (advice-add #'tracking-mode :override (lambda (&optional _) (interactive)))) + +(defun jao-tracking-remove-from-minibuffer () + (interactive) + (jao-minibuffer-remove-variable 'jao-tracking-string) + (remove-variable-watcher 'tracking-mode-line-buffers #'jao-tracking-echo) + (advice-remove #'tracking-mode (lambda (&optional _) (interactive)))) + +;;;###autoload +(defun jao-tracking-setup (&optional minibuffer) + (when minibuffer (jao-tracking-add-to-minibuffer)) + (add-hook 'jao-afio-switch-hook #'jao-tracking--remove-visible-buffers) + (global-set-key (kbd "C-c C-SPC") #'jao-tracking-next-buffer) + (define-key tracking-mode-map (kbd "C-c C-SPC") #'jao-tracking-next-buffer)) (provide 'jao-tracking) ;;; jao-minibuffer-tracking.el ends here diff --git a/lib/eos/jao-wayland.el b/lib/eos/jao-wayland.el new file mode 100644 index 0000000..e743eb0 --- /dev/null +++ b/lib/eos/jao-wayland.el @@ -0,0 +1,182 @@ +;;; jao-wayland.el --- interacting with wayland compositors -*- lexical-binding: t; -*- + +;; Copyright (C) 2022, 2023 jao + +;; Author: jao <mail@jao.io> +;; Keywords: convenience + +;; 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 <https://www.gnu.org/licenses/>. + +(require 'browse-url) +(require 'jao-shell) +(require 'jao-pdf) +(require 'jao-tracking) + +;;; wayland +(defvar jao-wayland-enabled + (string= "wayland" (or (getenv "XDG_SESSION_TYPE") ""))) + +(defsubst jao-wayland-type (&rest args) + (apply #'jao-shell-exec* t "wtype" args)) + +;;; river +(defvar jao-river-enabled (jao-shell-running-p "river")) +(defun jao-river-enabled-p () jao-river-enabled) + +(defsubst jao-river-to-ws (n) + (jao-wayland-type "-M" "win" (format "%s" n))) + +(defsubst jao-river-window-list () + (alist-get 'toplevels + (jao-shell-output "lswt -j" + (lambda () + (let ((json-false nil)) (json-read)))))) + +(defun jao-river-focused () + (seq-some (lambda (w) (and (alist-get 'activated w) w)) + (jao-river-window-list))) + +(defsubst jao-river-get-focused-title () + (alist-get 'title (jao-river-focused))) + +(defsubst jao-river-get-focused-app-id () + (alist-get 'app-id (jao-river-focused))) + +(defun jao-river-focus-window (title &optional rx) + (let* ((ws (jao-river-window-list)) + (fltr (if rx #'string-match-p #'string=)) + (w (seq-find (lambda (w) + (or (funcall fltr title (alist-get 'app_id w "")) + (funcall fltr title (alist-get 'title w "")))) + ws))) + (or (alist-get 'activated w) + (seq-some (lambda (_ignored) + (jao-shell-exec "riverctl focus-view next" t) + (or (funcall fltr title (jao-river-get-focused-app-id)) + (funcall fltr title (jao-river-get-focused-title)))) + (and w ws))))) + +(defun jao-river-zathura-to-org () + (let ((title (jao-river-get-focused-title))) + (jao-river-to-ws 1) + (jao-org-open-from-zathura title t))) + +(defun jao-river-zathura-kill-link () + (when-let* ((title (jao-river-get-focused-title)) + (lnk (jao-pdf-zathura-org-link title))) + (jao-river-to-ws 1) + (kill-new lnk) + (message "Link to %s killed" title))) + +(defun jao-river-find-zathura-window (file) + (let ((frx (regexp-quote (file-name-nondirectory file)))) + (seq-some (lambda (w) + (and (string-suffix-p ".zathura" (alist-get 'app_id w "")) + (string-match-p frx (alist-get 'title w "")) + w)) + (jao-river-window-list)))) + +(defun jao-river-open-with-zathura (file page) + (let ((wd (jao-river-find-zathura-window file))) + (jao-river-to-ws 3) + (or (and wd (jao-river-focus-window (alist-get 'title wd))) + (jao-shell-exec* "riverctl" "spawn" (jao-pdf-zathura-open-cmd file page))) + (when page (sit-for 0.2) (jao-wayland-type (format "%dg" page))))) + +(defun jao-river-set-wallpaper (f) + (jao-shell-kill-p "swaybg") + (jao-shell-exec* "riverctl" "spawn" (concat "swaybg -m fill -i " f))) + +(defun jao-river-restart-i3bar () + (interactive) + (jao-shell-kill-p "i3bar-river") + (jao-shell-exec "riverctl spawn i3bar-river") + (sit-for 0.2) + (jao-tracking-set-log "")) + +(defun jao-river-toggle-emacs () + (let ((erx "^p?emacs\\(client\\)?\\|\\(.* - emacs\\)")) + (if (or (string-match-p erx (jao-river-get-focused-title)) + (string-match-p erx (jao-river-get-focused-app-id))) + (jao-shell-exec "riverctl focus-previous-tags") + (jao-river-to-ws 1) + (unless (jao-river-focus-window erx t) + (jao-shell-exec* "riverctl" "spawn" "efoot"))))) + +(defun jao-river-toggle-firefox () + (if (string-match-p "Firefox" (or (jao-river-get-focused-app-id) "")) + (jao-river-to-ws 1) + (jao-river-to-ws 2) + (unless (jao-river-focus-window "Firefox") + (jao-shell-exec* "riverctl" "spawn" "firefox")))) + +;;; sway +(defun jao-sway-msg (msg) + (shell-command (format "swaymsg '%s' >/dev/null" msg))) + +(defmacro jao-def-swaymsg (name msg) + `(defun ,(intern (format "jao-sway-%s" name)) () + (interactive) + (jao-sway-msg ,msg))) + +(jao-def-swaymsg firefox "[app_id=Firefox] focus") +(jao-def-swaymsg pemacs "[app_id=pemacs] focus") + +(defvar jao-sway-enabled (jao-shell-running-p "sway")) + +(defconst jao-sway-get-active-title + "swaymsg -t get_tree | jq '.. | select(.type?) | select(.focused==true).name'") + +(defconst jao-sway-get-active-app + "swaymsg -t get_tree | jq '.. | select(.type?) | select(.focused==true).app_id'") + +(defun jao-sway-get-active-title () + (let ((tl (jao-shell-string jao-sway-get-active-title))) + (and (string-match "\"\\(.+\\)\"" tl) (match-string 1 tl)))) + +(defun jao-sway-get-active-app () + (let ((tl (jao-shell-string jao-sway-get-active-app))) + (and (string-match "\"\\(.+\\)\"" tl) (match-string 1 tl)))) + +(defun jao-sway-zathura-org () + (jao-org-open-from-zathura (jao-sway-get-active-title) t)) + +(defun jao-sway-open-with-zathura (file page) + (let* ((n (file-name-nondirectory file)) + (m (format "[title=\"%s\" app_id=\".*zathura\"] focus" n))) + (jao-sway-msg "workspace number 3") + (unless (= 0 (jao-sway-msg m)) + (jao-shell-exec (jao-pdf-zathura-open-cmd file page))) + (when page (sit-for 0.2) (jao-wayland-type (format "%dg" page))))) + +(defun jao-sway-set-wallpaper (f) + (jao-sway-msg (format "output * bg %s fill" f))) + +(defun jao-sway-run-or-focus (cmd &optional ws) + (if (jao-shell-running-p "firefox") + (jao-sway-msg (format "[app_id=%s] focus" cmd)) + (jao-sway-msg (format "workspace %s" (or ws 2))) + (start-process-shell-command cmd nil cmd))) + +(defun jao-sway-run-or-focus-firefox () + (interactive) + (jao-sway-run-or-focus "firefox")) + +(defun jao-sway-toggle-emacs () + (if (string-match-p "p?emacs" (jao-sway-get-active-app)) + (jao-sway-firefox) + (jao-sway-pemacs))) + +(provide 'jao-wayland) +;;; jao-wayland.el ends here diff --git a/lib/media/jao-lyrics.el b/lib/media/jao-lyrics.el index 5008fae..c00a913 100644 --- a/lib/media/jao-lyrics.el +++ b/lib/media/jao-lyrics.el @@ -1,6 +1,6 @@ -;; jao-lyrics.el -- simple show lyrics using glyrc +;; jao-lyrics.el -- simple show lyrics using glyrc -*- lexical-binding: t; -*- -;; Copyright (C) 2009, 2010, 2017, 2019, 2020, 2022 Jose Antonio Ortega Ruiz +;; Copyright (C) 2009, 2010, 2017, 2019, 2020, 2022, 2026 Jose Antonio Ortega Ruiz ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> ;; Start date: Sat Jul 04, 2009 13:41 @@ -76,7 +76,7 @@ (use-local-map jao-lyrics-mode-map) (setq major-mode 'jao-lyrics-mode) (setq mode-name "lyrics") - (toggle-read-only 1)) + (read-only-mode)) (defun jao-lyrics-buffer () (or (get-buffer "*Lyrics*") @@ -99,8 +99,13 @@ "^\\(CreditsWritten by:\\|External linksNominate\\)" nil t) (beginning-of-line) (kill-region (point) (point-max))) - (replace-string "
" "" nil (point-min) (point-max)) - (replace-string "\\'" "'" nil (point-min) (point-max)) + (goto-char (point-min)) + (save-excursion + (while (search-forward "
" nil t) + (replace-match ""))) + (save-excursion + (while (search-forward "\\'" nil t) + (replace-match "'"))) (save-buffer))) (defun jao-lyrics--download (artist title &optional noartist) @@ -115,7 +120,7 @@ (jao-lyrics--clean-download fn) (prog1 (jao-lyrics--get-cached artist title) (message nil)))) -(defvar jao-lyrics-info-function) +(defvar jao-lyrics-info-function nil) (defvar-local jao-lyrics--info-function nil) ;;;###autoload diff --git a/lib/media/jao-mpc.el b/lib/media/jao-mpc.el index dc8ff6d..23b2dda 100644 --- a/lib/media/jao-mpc.el +++ b/lib/media/jao-mpc.el @@ -1,6 +1,6 @@ ;;; jao-mpc.el --- Using mpc to interact with mpd -*- lexical-binding: t; -*- -;; Copyright (C) 2021, 2022 jao +;; Copyright (C) 2021, 2022, 2024, 2025, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: convenience @@ -30,6 +30,8 @@ (require 'jao-themes) (require 'jao-lyrics) (require 'jao-random-album) +(require 'jao-notify) +(require 'jao-minibuffer) (defconst jao-mpc--albums "*MPC Albums*") (defconst jao-mpc--playlist "*MPC Playlist*") @@ -38,98 +40,130 @@ (defvar-local jao-mpc--port nil) (defun jao-mpc--cmd (cmd &optional port) - (let ((port (or port jao-mpc--port jao-mpc-port))) - (shell-command-to-string (format "mpc -p %s %s" port cmd)))) + (let* ((port (or port jao-mpc--port jao-mpc-port)) + (r (shell-command-to-string (format "mpc -p %s %s" port cmd)))) + (replace-regexp-in-string "^\\(warning: \\)?MPD .+\n" "" r))) + +(defun jao-mpc--fformat (fields) + (mapconcat (lambda (f) (format "%s:::%%%s%%" f f)) fields "\n")) (defconst jao-mpc--fields - '(artist album composer originaldate genre title track position time name)) + '(artist album composer originaldate genre title track position time name + file)) (defconst jao-mpc--stfmt - (mapconcat (lambda (f) (format "%s:::%%%s%%" f f)) jao-mpc--fields "\n")) + (jao-mpc--fformat + '(artist album composer originaldate genre title track name file))) + +(defconst jao-mpc--stfmtt + (jao-mpc--fformat '(currenttime totaltime percenttime songpos length))) + +(defmacro jao-mpc--parse-fields (res-str res) + `(dolist (s (split-string ,res-str "\n" t " ") ,res) + (when (string-match "\\(.+\\):::\\(.+\\)" s) + (push (cons (intern (match-string 1 s)) (match-string 2 s)) ,res)))) (defun jao-mpc--current (&optional port) (let ((s (jao-mpc--cmd (format "-f '%s' current" jao-mpc--stfmt) port)) + (st (jao-mpc--cmd (format "status '%s'" jao-mpc--stfmtt))) (res)) - (dolist (s (split-string s "\n" t " ") res) - (when (string-match "\\(.+\\):::\\(.+\\)" s) - (push (cons (intern (match-string 1 s)) (match-string 2 s)) res))))) - -(defun jao-mpc--playing-p (&optional port) - (not (string-blank-p (jao-mpc--cmd "status|grep '\\[playing\\]'" port)))) - -(defun jao-mpc--queue-len (&optional port) - (string-to-number (jao-mpc--cmd "playlist|wc -l" port))) - -(defsubst jao--put-face (str face) - (put-text-property 0 (length str) 'face face str) - str) - -(defun jao-mpc--current-str (&optional port current len) - (let* ((current (or current (jao-mpc--current port))) - (len (or len (jao-mpc--queue-len port))) - (title (alist-get 'title current (alist-get 'name current ""))) - (album (alist-get 'album current)) - (artist (alist-get 'artist current)) - (composer (alist-get 'composer current)) - (no (string-to-number (alist-get 'position current "0"))) - (time (alist-get 'time current ""))) - (format "> %s%s %s%s%s%s" ;; ï…„ - (jao--put-face (if (zerop no) "" (format "%02d/%s " no len)) - 'jao-themes-f02) - (jao--put-face title 'jao-themes-f00) - (jao--put-face artist 'jao-themes-f01) - (jao--put-face (if composer (format " [%s]" composer) "") - 'jao-themes-f01) - (jao--put-face (if album (format " (%s)" album) "") 'jao-themes-f11) - (if (string-blank-p time) - "" - (jao--put-face (format " [%s]" time) 'jao-themes-dimm))))) + (jao-mpc--parse-fields s res) + (jao-mpc--parse-fields st res))) + +(defsubst jao-mpc-status (&optional port) + (string-trim (jao-mpc--cmd "status %state%" port))) + +(defsubst jao-mpc-playing-p (&optional port) + (string-prefix-p "playing" (jao-mpc-status port))) + +(defsubst jao-mpc--queue-len (&optional port) + (string-to-number (jao-mpc--cmd "status %length%" port))) + +(defun jao-mpc--current-timestr (playing-times &optional current) + (let* ((current (or current (jao-mpc--current))) + (time (alist-get 'totaltime current "")) + (remaining (jao-mpc-playlist-duration-string current))) + (if playing-times + (format "%s/%s%s - %s" + (alist-get 'currenttime current "") + time + (alist-get 'percenttime current "") + remaining) + (format "%s - %s" time remaining)))) + +(defun jao-mpc--current-str (&optional port times) + (if-let* ((current (jao-mpc--current port)) + (title (alist-get 'title current (alist-get 'name current)))) + (let ((len (alist-get 'length current "0")) + (album (alist-get 'album current)) + (artist (alist-get 'artist current)) + (composer (alist-get 'composer current)) + (no (string-to-number (alist-get 'songpos current "0"))) + (tims (concat " [" (jao-mpc--current-timestr times current) "]"))) + (format "%s%s %s%s%s%s" ;; ï…„ + (jao--put-face (if (zerop no) "" (format "%d/%s " no len)) + 'jao-themes-f02) + (jao--put-face (or title "") 'jao-themes-f00) + (jao--put-face (or artist "") 'jao-themes-f01) + (jao--put-face (if composer (format " [%s]" composer) "") + 'jao-themes-f01) + (jao--put-face (if album (format " (%s)" album) "") + 'jao-themes-f11) + (jao--put-face tims (if times 'jao-themes-f00 'jao-themes-dimm)))) + "")) (defvar jao-mpc-minibuffer-str "") (defun jao-mpc--set-current-str (&optional port) - (setq jao-mpc-minibuffer-str - (if (jao-mpc--playing-p port) - (jao-mpc--current-str port) - (when (and (null port) jao-random-album-p (not (jao-mpc--current))) - (jao-random-album-next)) - "")) + (let ((status (or (jao-mpc-status port) ""))) + (setq jao-mpc-minibuffer-str + (if (string= "playing" status) (jao-mpc--current-str port) "")) + (when (and jao-random-album-active + (or (string= status "stopped") (string= status "paused")) + (string= "0\n" (jao-mpc--cmd "status %songpos%" port))) + (jao-random-album-next))) (jao-minibuffer-refresh)) (defvar jao-mpc--idle-procs nil) (defun jao-mpc--idle-loop (&optional port) - (when-let (proc (alist-get port jao-mpc--idle-procs)) + (when-let* ((proc (alist-get port jao-mpc--idle-procs))) (ignore-errors (kill-process proc))) (setf (alist-get port jao-mpc--idle-procs nil t) (make-process :name (format "jao-mpc-idleloop (%s)" port) :buffer nil :noquery t - :command `("mpc" "-p" ,(format "%s" (or port jao-mpc-port)) - "idleloop" "player") - :filter (lambda (_p _s) (jao-mpc--set-current-str port))))) + :command + `("mpc" "-p" ,(format "%s" (or port jao-mpc-port)) + "idleloop" "player") + :filter (lambda (_p _s) + (jao-mpc--set-current-str port))))) + +(defvar jao-mpc--browser-port nil) (define-derived-mode jao-mpc-albums-mode fundamental-mode "MPC Albums" "Mode to display the list of albums known by mpd." (read-only-mode -1) (delete-region (point-min) (point-max)) - (insert (jao-mpc--cmd "list album")) + (insert (jao-mpc--cmd "list album" jao-mpc--browser-port)) (goto-char (point-min)) (read-only-mode 1)) (defun jao-mpc--album-buffer () - (if-let (b (get-buffer jao-mpc--albums)) + (if-let* ((b (get-buffer jao-mpc--albums))) b (with-current-buffer (get-buffer-create jao-mpc--albums) (jao-mpc-albums-mode) (current-buffer)))) -(defun jao-mpc--add-and-play (&optional album) +(defun jao-mpc--add-and-play (&optional album port idp) (interactive) - (let ((album (or album (string-trim (thing-at-point 'line))))) - (jao-mpc--cmd "clear") - (jao-mpc--cmd (format "findadd album \"%s\"" album)) - (jao-mpc--cmd "play"))) + (let ((a (or album (string-trim (thing-at-point 'line)))) + (p (or port jao-mpc--browser-port))) + (jao-mpc--cmd "clear" p) + (jao-mpc--cmd (if idp (concat "add " a) (format "findadd album \"%s\"" a)) + p) + (jao-mpc--cmd "play" p))) (define-key jao-mpc-albums-mode-map (kbd "n") #'next-line) (define-key jao-mpc-albums-mode-map (kbd "p") #'previous-line) @@ -161,7 +195,8 @@ (define-key jao-mpc-playlist-mode-map (kbd "n") #'next-line) (define-key jao-mpc-playlist-mode-map (kbd "p") #'previous-line) (define-key jao-mpc-playlist-mode-map (kbd "q") #'bury-buffer) -(define-key jao-mpc-playlist-mode-map (kbd ".") #'jao-mpc--playlist-goto-current) +(define-key jao-mpc-playlist-mode-map (kbd ".") + #'jao-mpc--playlist-goto-current) (define-key jao-mpc-playlist-mode-map (kbd "RET") #'jao-mpc--playlist-play) (define-key jao-mpc-playlist-mode-map (kbd "C") #'jao-mpc-clear) @@ -170,15 +205,52 @@ (let ((jao-mpc-port (or port jao-mpc-port))) (jao-mpc-playlist-mode)) (current-buffer))) +(defun jao-mpc--with-delayed-random-album (cmd port) + (let ((st jao-random-album-active)) + (setq jao-random-album-active nil) + (jao-mpc--cmd cmd port) + (accept-process-output nil 0.5) + (setq jao-random-album-active st))) + +(defun jao-mpc--time-to-secs (str) + (if-let* ((ts (string-split (or str "") ":")) + (mins (string-to-number (car ts))) + (secs (string-to-number (or (cadr ts) "0")))) + (+ secs (* 60 mins)) + 0)) + +(defun jao-mpc--playlist-duration (&optional current port) + (let* ((current (or current (jao-mpc--current))) + (times (string-split (jao-mpc--cmd "playlist -f %time%") nil t)) + (offset (- (string-to-number (alist-get 'songpos current "1")) 1)) + (times (drop offset times)) + (total (- (jao-mpc--time-to-secs (alist-get 'currenttime current))))) + (dolist (time times total) + (setq total (+ total (jao-mpc--time-to-secs time)))))) + +;;;###autoload +(defun jao-mpc-playlist-duration-string (&optional current) + (format-seconds "%hh %mm %ss" (jao-mpc--playlist-duration current))) + +;;;###autoload +(defun jao-mpc-show-playlist-duration () + (interactive) + (message (jao-mpc-playlist-duration-string))) + ;;;###autoload (defun jao-mpc-stop (&optional port) (interactive) - (jao-mpc--cmd "stop" port)) + (jao-mpc--with-delayed-random-album "stop" port)) ;;;###autoload (defun jao-mpc-toggle (&optional port) (interactive) - (jao-mpc--cmd "toggle" port)) + (jao-mpc--with-delayed-random-album "toggle" port)) + +;;;###autoload +(defun jao-mpc-pause (&optional port) + (interactive) + (jao-mpc--with-delayed-random-album "pause" port)) ;;;###autoload (defun jao-mpc-play (&optional port) @@ -208,7 +280,29 @@ ;;;###autoload (defun jao-mpc-echo-current (&optional port) (interactive) - (jao-notify (jao-mpc--current-str port))) + (message "%s" (jao-mpc--current-str port t))) + +;;;###autoload +(defun jao-mpc-echo-current-times (&optional _port) + (interactive) + (message "Playing time: %s" (jao-mpc--current-timestr t))) + +;;;###autoload +(defun jao-mpc-notify (&optional _port) + (interactive) + (when-let* ((current (jao-mpc--current))) + (let* ((artist (or (alist-get 'artist current) "Anonymous")) + (title (or (alist-get 'title current) + (when-let* ((tl (alist-get 'file current))) + (file-name-base tl)) + "")) + (album (or (alist-get 'album current) "")) + (track (or (alist-get 'track current) "")) + (times (jao-mpc--current-timestr t current))) + (jao-notify (format "%s -- %s" artist times) + (format "%s %s" track title) + jao-notify-audio-icon + album)))) ;;;###autoload (defun jao-mpc-add-url (url) @@ -216,9 +310,33 @@ (jao-mpc--cmd (format "add %s" url))) ;;;###autoload -(defun jao-mpc-show-albums () +(defun jao-mpc-add-or-play-url (url &optional play) + "Add the given URL to mpc's playing list, or just play it." + (let ((p (or play (yes-or-no-p (format "Play %s right now?" url))))) + (when p (jao-mpc-clear)) + (jao-mpc-add-url url) + (if p (jao-mpc-play) (message "%s added to mpc queue" url)))) + +(defvar jao-mpc-stream-urls + '(("classic fm" . "http://media-ice.musicradio.com:80/ClassicFMMP3") + ("wcpe" . "http://audio-mp3.ibiblio.org:8000/wcpe.mp3") + ("davide of mimic" . "http://streaming01.zfast.co.uk:8018/stream") + ("cinemix" . "http://94.23.51.96:8000") ;; 209.9.238.4:6022 209.9.238.4:6046 + ("bbc gold" . "http://media-ice.musicradio.com:80/GoldMP3") + ("irish gold" . "http://icecast2.rte.ie/gold"))) + +;;;###autoload +(defun jao-mpc-play-stream () + "Select a predefined stream URL and add or play it in mpc." + (interactive) + (let ((s (completing-read "Stream: " jao-mpc-stream-urls))) + (jao-mpc-add-or-play-url (cdr (assoc s jao-mpc-stream-urls)) t))) + +;;;###autoload +(defun jao-mpc-show-albums (&optional port) "Show album list." (interactive) + (setq jao-mpc--browser-port port) (pop-to-buffer (jao-mpc--album-buffer))) ;;;###autoload @@ -239,35 +357,35 @@ (defun jao-mpc-connect (&optional port) (interactive) (jao-mpc--idle-loop port) - (when (jao-mpc--playing-p port) (jao-mpc--set-current-str port))) + (when (jao-mpc-playing-p port) (jao-mpc--set-current-str port))) ;;;###autoload (defun jao-mpc-setup (&optional secondary-port priority) (setq jao-lyrics-info-function #'jao-mpc-lyrics-track-data) (jao-random-album-setup #'jao-mpc--album-buffer #'jao-mpc--add-and-play - #'jao-mpc-stop - jao-notify-audio-icon) - (jao-mpc-connect) + #'jao-mpc-stop) + (let ((jao-random-album-active nil)) (jao-mpc-connect)) (when secondary-port (jao-mpc-connect secondary-port)) (when priority (if (> priority 0) (jao-minibuffer-add-variable 'jao-mpc-minibuffer-str priority) (jao-minibuffer-add-msg-variable 'jao-mpc-minibuffer-str (- priority))))) -(defvar jao-mpc--album-titles nil) (defconst jao-mpc--albums-cmd "-f '%album% - %artist%' find \"(ALBUM =~ '.*')\" | uniq") +(defconst jao-mpc--simple-albums-cmd "list album") ;;;###autoload -(defun jao-mpc-select-album (refresh) - (interactive "P") - (let ((albums (or (and (not refresh) jao-mpc--album-titles) - (setq jao-mpc--album-titles - (split-string (jao-mpc--cmd jao-mpc--albums-cmd) - "\n" t))))) - (when-let (album (completing-read "Play album: " albums nil t)) - (jao-mpc--add-and-play (car (split-string album "-" t " ")))))) +(defun jao-mpc-select-album (&optional port) + (interactive) + (let* ((albums-str (jao-mpc--cmd jao-mpc--albums-cmd port)) + (albums-str (if (string= "" albums-str) + (jao-mpc--cmd jao-mpc--simple-albums-cmd port) + albums-str)) + (albums (split-string albums-str "\n" t))) + (when-let* ((album (completing-read "Play album: " albums nil t))) + (jao-mpc--add-and-play (car (split-string album "-" t " ")) port)))) (provide 'jao-mpc) ;;; jao-mpc.el ends here diff --git a/lib/media/jao-mpris.el b/lib/media/jao-mpris.el index 47a35a7..c120ae3 100644 --- a/lib/media/jao-mpris.el +++ b/lib/media/jao-mpris.el @@ -1,6 +1,6 @@ ;;; jao-mpris.el --- mpris players control -*- lexical-binding: t; -*- -;; Copyright (C) 2020, 2021, 2022 jao +;; Copyright (C) 2020, 2021, 2022, 2024, 2025, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: multimedia @@ -51,10 +51,9 @@ (interactive "p") (jao-mpris-seek (- secs))) -(defun jao-mpris-vol (n) +(defun jao-mpris-vol (vol) (interactive "p") - (let ((secs (if (zerop n) 10 n))) - (jao-mpris--playerctl "volume" (format "%d" n)))) + (jao-mpris--playerctl "volume" (format "%d" (if (zerop vol) 10 vol)))) (defun jao-mpris-vol-down (n) (interactive "p") @@ -97,7 +96,7 @@ jao-mpris--current nil)) (defun jao-mpris--get (k &optional l) - (when-let (v (alist-get k (or l jao-mpris--current))) + (when-let* ((v (alist-get k (or l jao-mpris--current)))) (if (consp v) (car v) v))) (defun jao-mpris--set-current (k v) @@ -119,7 +118,7 @@ (duration (cond (duration duration) ((stringp len) len) ((numberp len) (jao-mpris--fmt-time (/ len 1e6) ""))))) - (format "> %s %s %s%s%s" + (format "%s %s %s%s%s" (jao--put-face (format "%s" (or track "")) 'jao-themes-f00) (jao--put-face (or title "") 'jao-themes-f01) (jao--put-face (or artist "") 'jao-themes-f11) @@ -130,6 +129,7 @@ (defun jao-mpris--track (&optional info) (let ((info (or info (jao-playerctl--status)))) + (setq jao-mpris--current info) (if (string= "Playing" (jao-mpris--get 'status info)) (setq jao-mpris-track-string (jao-mpris--format info)) (setq jao-mpris-track-string ""))) @@ -145,9 +145,10 @@ (interactive "P") (when refresh (jao-mpris--track)) (when jao-mpris--current - (jao-notify (format "%s%s" (if-let (s (jao-mpris--get 'status)) - (format "%s: " s) - "") + (jao-notify (format "%s%s" + (if-let* ((s (jao-mpris--get 'status))) + (format "%s: " s) + "") (jao-mpris--format))))) (defun jao-mpris-minibuffer-order (order) @@ -157,25 +158,25 @@ (defun jao-mpris--handler (iname properties &rest _args) (let ((inhibit-message t)) - (message "Received properties: %S from %s" properties iname)) - (when-let (md (caadr (assoc "Metadata" properties))) - (let ((tno (caadr (assoc "xesam:trackNumber" md))) - (tlt (caadr (assoc "xesam:title" md))) - (art (caadr (assoc "xesam:artist" md))) - (alb (caadr (assoc "xesam:album" md))) - (len (caadr (assoc "mpris:length" md)))) - (if (string= (or tlt "") "TIDAL") - (jao-mpris-reset) + (message "Received properties: %S from %s" properties iname) + (when-let* ((md (caadr (assoc "Metadata" properties)))) + (let ((tno (caadr (assoc "xesam:trackNumber" md))) + (tlt (caadr (assoc "xesam:title" md))) + (art (caadr (assoc "xesam:artist" md))) + (alb (caadr (assoc "xesam:album" md))) + (len (caadr (assoc "mpris:length" md)))) (jao-mpris--set-current 'track tno) (jao-mpris--set-current 'title tlt) (jao-mpris--set-current 'artist art) (jao-mpris--set-current 'album alb) - (jao-mpris--set-current 'length len)))) - (when-let (st (caadr (assoc "PlaybackStatus" properties))) - (jao-mpris--set-current 'status st) - (when (string= st "Stopped") - (dolist (k '(track title artist album length)) - (jao-mpris--del-current k)))) + (jao-mpris--set-current 'length len))) + (when-let* ((st (caadr (assoc "PlaybackStatus" properties)))) + (jao-mpris--set-current 'status st) + (when (string= st "Stopped") + (dolist (k '(track title artist album length)) + (jao-mpris--del-current k)))) + ;; (message "Current is: %S" jao-mpris--current) + ) (jao-mpris--track jao-mpris--current)) ;;;###autoload diff --git a/lib/media/jao-random-album.el b/lib/media/jao-random-album.el index 2800115..540f6a6 100644 --- a/lib/media/jao-random-album.el +++ b/lib/media/jao-random-album.el @@ -1,6 +1,6 @@ -;; jao-random-album.el -- play random albums +;; jao-random-album.el -- play random albums -*- lexical-binding: t; -*- -;; Copyright (C) 2009, 2010, 2017, 2018, 2019, 2021 Jose Antonio Ortega Ruiz +;; Copyright (C) 2009, 2010, 2017-2019, 2021-2022, 2024, 2026 Jose Antonio Ortega Ruiz ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> ;; Start date: Sat Jul 04, 2009 13:06 @@ -18,38 +18,33 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <http://www.gnu.org/licenses/>. -(require 'jao-notify) +(require 'multisession) -(defvar jao-random-album-p t) -(defvar jao-random-lines nil) -(defvar jao-random-lines-file (expand-file-name "~/.emacs.d/random-lines")) -(defvar jao-random-album-notify-p t) -(defvar jao-random-album-notify-icon jao-notify-audio-icon) +(defvar jao-random-album-active t) +(defvar jao-random-album-notify nil) (defvar jao-random-album-skip-lines 2) +(define-multisession-variable jao-random-lines nil) + +(defun jao-random-album--buffer-lines () + (let ((lines nil)) + (dotimes (n (1- (line-number-at-pos (point-max)))) + (when (> n jao-random-album-skip-lines) + (push (1+ n) lines))) + lines)) + (defun jao-random-lines () - (or jao-random-lines - (and (file-exists-p jao-random-lines-file) - (with-current-buffer - (find-file-noselect jao-random-lines-file) - (goto-char (point-min)) - (setq jao-random-lines (read (current-buffer))))) - (dotimes (n (1- (line-number-at-pos (point-max))) - jao-random-lines) - (when (> n jao-random-album-skip-lines) - (push (1+ n) jao-random-lines))))) - -(defun jao-random-lines-save () - (with-current-buffer (find-file-noselect jao-random-lines-file) - (delete-region (point-min) (point-max)) - (insert (format "%s\n" jao-random-lines)) - (save-buffer))) + (or (multisession-value jao-random-lines) + (jao-random-lines-save (jao-random-album--buffer-lines)))) + +(defun jao-random-lines-save (v) + (setf (multisession-value jao-random-lines) v)) (defun jao-goto-random-album () - (let* ((pos (random (length (jao-random-lines)))) - (line (nth pos jao-random-lines))) - (setq jao-random-lines (remove line jao-random-lines)) - (jao-random-lines-save) + (let* ((lines (jao-random-lines)) + (pos (random (length lines))) + (line (nth pos lines))) + (jao-random-lines-save (remove line lines)) (goto-line line))) @@ -58,41 +53,45 @@ (defvar jao-random-album-add-tracks-and-play) (defvar jao-random-album-stop) +;;;###autoload (defun jao-random-album-start () (interactive) - (setq jao-random-album-p t) + (setq jao-random-album-active t) (jao-random-album-next)) +;;;###autoload (defun jao-random-album-stop () (interactive) - (setq jao-random-album-p nil) + (setq jao-random-album-active nil) (funcall jao-random-album-stop)) +;;;###autoload (defun jao-random-album-toggle () (interactive) - (setq jao-random-album-p (not jao-random-album-p)) + (setq jao-random-album-active (not jao-random-album-active)) (message "Random album %s" - (if jao-random-album-p "enabled" "disabled"))) + (if jao-random-album-active "enabled" "disabled"))) +;;;###autoload (defun jao-random-album-next () (interactive) (with-current-buffer (get-buffer (funcall jao-random-album-buffer)) (jao-goto-random-album) (let ((album (string-trim (thing-at-point 'line)))) (funcall jao-random-album-add-tracks-and-play album) - (when jao-random-album-notify-p - (jao-notify album "Next album" jao-random-album-notify-icon))))) + (when jao-random-album-notify + (funcall jao-random-album-notify album))))) +;;;###autoload (defun jao-random-album-reset () (interactive) - (setq jao-random-lines nil) - (jao-random-lines-save)) + (jao-random-lines-save nil)) -(defun jao-random-album-setup (album-buffer add-and-play stop &optional icon) +;;;###autoload +(defun jao-random-album-setup (album-buffer add-and-play stop) (setq jao-random-album-buffer album-buffer jao-random-album-add-tracks-and-play add-and-play - jao-random-album-stop stop - jao-random-album-notify-icon icon)) + jao-random-album-stop stop)) (provide 'jao-random-album) diff --git a/lib/media/jao-spt.el b/lib/media/jao-spt.el deleted file mode 100644 index 4484ead..0000000 --- a/lib/media/jao-spt.el +++ /dev/null @@ -1,148 +0,0 @@ -;;; jao-spt.el --- Access to the spotify-tui CLI -*- lexical-binding: t; -*- - -;; Copyright (C) 2021, 2022 jao - -;; Author: jao <mail@jao.io> -;; Keywords: multimedia - -;; 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 <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Simple spotifyd controls via the spt executable. - -;;; Code: - -(require 'jao-minibuffer) -(require 'jao-notify) - -(defvar jao-spt-bin (expand-file-name "~/bin/spt")) -(defvar jao-spt-format "'%s %t - %a [%r] %f'") -(defvar jao-spt-device nil) - -(defun jao-spt--exec-async (&rest args) - (let ((display-buffer-alist `((".*spt commands.*" display-buffer-no-window))) - (buff (get-buffer-create "* spt commands *"))) - (apply #'start-process "spt" buff jao-spt-bin args))) - -(defvar jao-spt--status-str "") - -(defun jao-spt--pb (&rest args) - (let* ((args (mapconcat #'identity args " ")) - (dev (if jao-spt-device (format "-d '%s'" jao-spt-device) "")) - (cmd (format "%s pb %s -f %s %s" jao-spt-bin args jao-spt-format dev)) - (st (string-trim (shell-command-to-string cmd)))) - (setq jao-spt--status-str (when (string-prefix-p "â–¶" st) st)) - (jao-minibuffer-refresh) - st)) - -(defun jao-spt--pb* (&rest args) - (message (apply 'jao-spt--pb args))) - -;;;###autoload -(defun jao-spt-play-uri (uri) - (jao-spt--exec-async "play" "--uri" uri)) - -;;;###autoload -(defun jao-spt-update-status () - (interactive) - (jao-spt--pb)) - -;;;###autoload -(defun jao-spt-toggle () - (interactive) - (jao-spt--pb* "-t")) - -;;;###autoload -(defun jao-spt-next () - (interactive) - (jao-spt--pb* "-n")) - -;;;###autoload -(defun jao-spt-previous () - (interactive) - (jao-spt--pb* "-p")) - -;;;###autoload -(defun jao-spt-like () - (interactive) - (jao-spt--pb* "--like")) - -;;;###autoload -(defun jao-spt-dislike () - (interactive) - (jao-spt--pb* "--dislike")) - -;;;###autoload -(defun jao-spt-toggle-shuffle () - (interactive) - (jao-spt--pb* "--shuffle")) - -;;;###autoload -(defun jao-spt-seek (&optional secs) - (interactive "p") - (let ((secs (if (zerop (or secs 0)) 10 secs))) - (jao-spt--pb* "--seek" (format "%d" secs)))) - -;;;###autoload -(defun jao-spt-seek-back (&optional secs) - (interactive "p") - (jao-spt-seek (- secs))) - -(defun jao-spt--get-vol (delta) - (let* ((jao-spt-format "%v") - (v (string-to-number (jao-spt--pb)))) - (number-to-string (max 0 (+ delta v))))) - -;;;###autoload -(defun jao-spt-vol (&optional n) - (interactive "p") - (let ((n (or n 10))) - (jao-spt--pb* "--volume" (jao-spt--get-vol (if (zerop n) 10 n))))) - -;;;###autoload -(defun jao-spt-vol-down (&optional n) - (interactive "p") - (jao-spt-vol (- (or n 10)))) - -;;;###autoload -(defun jao-spt-echo-current () - (interactive) - (let ((jao-notify-use-messages-p t)) - (jao-notify (jao-spt-update-status)))) - -;;;###autoload -(defun jao-spt-toggle-shuffle () - (interactive) - (jao-spt--pb* "--shuffle")) - -;;;###autoload -(defun jao-spt-set-up () - (jao-minibuffer-add-msg-variable 'jao-spt--status-str)) - -(defun jao-spt-lyrics-info () - (let* ((jao-spt-format "%a~~~%t") - (s (jao-spt--pb)) - (at (split-string s "~~~"))) - (cons (car at) (cadr at)))) - -(declare jao-show-lyrics "jao-lyrics") - -;;;###autoload -(defun jao-spt-show-lyrics (force) - (interactive "P") - (jao-show-lyrics force #'jao-spt-lyrics-info)) - -(provide 'jao-spt) -;;; jao-spt.el ends here diff --git a/lib/net/jao-eww-session.el b/lib/net/jao-eww-session.el index 9a34656..76da717 100644 --- a/lib/net/jao-eww-session.el +++ b/lib/net/jao-eww-session.el @@ -1,6 +1,6 @@ ;;; jao-eww-session.el --- Persistent eww sessions -*- lexical-binding: t; -*- -;; Copyright (C) 2003, 2004, 2006, 2007, 2008, 2009, 2012, 2021, 2022 Jose A Ortega Ruiz +;; Copyright (C) 2003-2004, 2006-2009, 2012, 2021-2022, 2025-2026 Jose A Ortega Ruiz ;; Author: Jose A Ortega Ruiz <jao@gnu.org> ;; Version: 0.4 @@ -21,212 +21,86 @@ ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. -;;; Commentary: - -;; jao-eww-session provides persistent eww browsing sessions. When -;; quitting eww (or, if you request it, at any other time while using -;; it) you can save the current eww session (that is, the set of open -;; tabs and the URLs they're visiting). Upon restarting emacs, you'll -;; have the possibity of recovering the saved session (that is, of -;; re-opening the saved tabs and URLs). You also have at your disposal -;; a command to recover the saved session at any other time, via the -;; commands: -;; -;; jao-eww-session-load -- load the last stored session -;; jao-eww-session-save -- save the current session -;; -;; A customization group, jao-eww-session, is available. There you can -;; customize the following variables: - ;;; Code: ;;; Dependencies: (require 'eww) (require 'url) - -;;; Custom variables: - -(defgroup jao-eww-session nil - "eww - session saving in eww." - :group 'eww - :prefix "jao-eww-session-") - -(defcustom jao-eww-session-save-always nil - "If on, always save eww session without asking." - :type 'boolean) - -(defcustom jao-eww-session-load-always t - "If on, always load eww session without asking." - :type 'boolean) - -(defcustom jao-eww-session-show-titles t - "If on, show URL titles in the load prompt." - :type 'boolean) - -(defcustom jao-eww-session-duplicate-tabs 'never - "How to treat session URL already being visited. - -When loading a session with `jao-eww-session-load', if one of the URLs in -the session is already displayed in a eww tab, jao-eww-session can: -- `never' create a new tab (just reload it), or -- `always' duplicate the URL in a new tab, or -- `ask' the user what to do." - :type '(choice (const :value never) - (const :value always) - (const :value ask))) - -(defcustom jao-eww-session-file "~/.emacs.d/eww-session.eld" - "File to save the eww session data." - :type 'file) +(require 'multisession) ;;; Internals: ;;;; auxiliary functions -(defvar jao-eww-current-session '(jao-eww-session 0 nil)) +(define-multisession-variable jao-eww-session '(0)) -(defun jao-eww-session--list-buffers (&optional skip) +(defun jao-eww-session--current (&optional s) + (when s (setf (multisession-value jao-eww-session) s)) + (multisession-value jao-eww-session)) + +(defun jao-eww-session-eww-buffers (&optional skip) (seq-filter (lambda (b) (when (not (eq b skip)) (with-current-buffer b (derived-mode-p 'eww-mode)))) (buffer-list))) -(defun jao-eww-session-invisible-buffers () - (seq-filter (lambda (b) (null (get-buffer-window b))) - (jao-eww-session--list-buffers (current-buffer)))) - (defun jao-eww--current-url () - (when-let (url (eww-current-url)) (url-encode-url url))) + (when-let* ((url (eww-current-url))) (url-encode-url url))) (defun jao-eww-session--current-urls (&optional skip-current) (let ((urls) (cb (current-buffer)) (pos 0) (count 0)) - (dolist (b (jao-eww-session--list-buffers (when skip-current cb)) + (dolist (b (jao-eww-session-eww-buffers (when skip-current cb)) (list pos (reverse urls))) (set-buffer b) - (when-let (url (jao-eww--current-url)) + (when-let* ((url (jao-eww--current-url))) (when (eq b cb) (setq pos count)) (setq count (1+ count)) (push (cons url (jao-eww-buffer-title)) urls))))) (defun jao-eww-session-urls (&optional s) - (let ((s (or s jao-eww-current-session))) - (mapcar 'car (nth 2 s)))) + (mapcar 'car (cadr (or s (jao-eww-session--current))))) (defun jao-eww-session-offset (&optional s) - (let ((s (or s jao-eww-current-session))) - (nth 1 s))) + (car (or s (jao-eww-session--current)))) (defun jao-eww-session-titles (&optional s) - (let ((s (or s jao-eww-current-session))) - (mapcar 'cdr (nth 2 s)))) + (let ((s (or s (jao-eww-session--current)))) + (mapcar 'cdr (cadr s)))) -(defun jao-eww-session--update-current (&optional skip-current) - (save-current-buffer - (setq jao-eww-current-session - (cons 'jao-eww-session (jao-eww-session--current-urls skip-current))))) +(defun jao-eww-session--update () + (jao-eww-session--current (jao-eww-session--current-urls))) (defun jao-eww-session--find-dups (urls) (seq-filter (lambda (b) - (with-current-buffer b - (when-let (url (jao-eww--current-url)) - (when (member url urls) - (when (y-or-n-p "Already open session, abort? ") - (switch-to-buffer b) - (user-error "Aborted")) - (or (and (eq jao-eww-session-duplicate-tabs 'never)) - (not (y-or-n-p (format "'%s' (%s) is already open. Duplicate? " - (jao-eww-buffer-title) url)))))))) - (jao-eww-session--list-buffers))) - -(defun jao-eww-session-load-aux () - (let ((new-session (jao-eww-session-from-file - (expand-file-name jao-eww-session-file)))) - (when (and new-session - (or jao-eww-session-load-always - (y-or-n-p - (if jao-eww-session-show-titles - (format "Load last eww session %S? " - (jao-eww-session-titles new-session)) - "Load last eww session? ")))) - (setq jao-eww-current-session new-session)))) - -(defun jao-eww-session-from-file (fname) - (let ((fname (jao-eww-session--check--backup fname))) - (when (file-readable-p fname) - (with-temp-buffer - (insert-file-contents fname) - (goto-char (point-min)) - (let ((sexp (read (current-buffer)))) - (and (equal 'jao-eww-session (car sexp)) sexp)))))) - -(defun jao-eww-session-not-empty () (> (length (jao-eww-session-urls)) 0)) - -(defun jao-eww-session--to--file (filename &optional skip) - (require 'pp) - (when (jao-eww-session-not-empty) - (let ((inhibit-message t) - (session (jao-eww-session--update-current skip))) - (with-temp-buffer - (insert ";;;; File generated by jao-eww-session. DO NOT EDIT!\n") - (pp session (current-buffer)) - (insert "\n" ";;;; End of " - (file-name-nondirectory jao-eww-session-file) "\n") - (write-region (point-min) (point-max) (expand-file-name filename)))))) - -(defun jao-eww-session--backup-name (fname) - (concat (expand-file-name fname) ".bak")) - -(defun jao-eww-session--check--backup (fname) - (let ((bfname (jao-eww-session--backup-name fname))) - (if (and (file-newer-than-file-p bfname fname) - (y-or-n-p "A newer autosaved session exists. Use it? ")) - bfname - fname))) - -(defun jao-eww-session--save-backup (&optional skip) - (let ((f (jao-eww-session--backup-name jao-eww-session-file))) - (jao-eww-session--to--file f skip))) - -(defun jao-eww-session--save-backup-1 () - (when (derived-mode-p 'eww-mode) (jao-eww-session--save-backup t))) + (with-current-buffer b (member (jao-eww--current-url) urls))) + (jao-eww-session-eww-buffers))) ;;;; save session on checkpoints -(add-hook 'kill-emacs-query-functions #'jao-eww-session-save) -(add-hook 'kill-buffer-hook #'jao-eww-session--save-backup-1) -(add-hook 'eww-after-render-hook #'jao-eww-session--save-backup) -(advice-add 'eww-back-url :after #'jao-eww-session--save-backup) -(advice-add 'eww-forward-url :after #'jao-eww-session--save-backup) +(add-hook 'eww-after-render-hook #'jao-eww-session--update) +(advice-add 'eww-back-url :after #'jao-eww-session--update) +(advice-add 'eww-forward-url :after #'jao-eww-session--update) -;;;###autoload (defun jao-eww-buffer-title () (plist-get eww-data :title)) -;;;###autoload -(defun jao-eww-session-save () - "Save the current eww session." - (interactive) - (when (and (jao-eww-session-not-empty) - (or jao-eww-session-save-always (y-or-n-p "Save eww session? "))) - (jao-eww-session--to--file jao-eww-session-file)) - t) - -;;;###autoload (defun jao-eww-session-load () "Load last stored session into eww." (interactive) - (when-let ((s (jao-eww-session-load-aux))) - (let* ((urls (jao-eww-session-urls s)) - (offset (jao-eww-session-offset s)) - (buffers (unless (equal jao-eww-session-duplicate-tabs 'always) - (jao-eww-session--find-dups urls)))) - (dolist (url urls) (eww url 4)) - (seq-each #'kill-buffer buffers) - (unless (zerop offset) - (switch-to-buffer (nth offset (jao-eww-session--list-buffers))))))) + (let* ((urls (jao-eww-session-urls)) + (offset (jao-eww-session-offset)) + (dups (jao-eww-session--find-dups urls))) + (dolist (url urls) (eww url 4)) + (seq-each #'kill-buffer dups) + (unless (zerop offset) + (switch-to-buffer (nth offset (jao-eww-session-eww-buffers)))))) + +(defun jao-eww-session-invisible-buffers () + (seq-filter (lambda (b) (null (get-buffer-window b))) + (jao-eww-session-eww-buffers (current-buffer)))) (provide 'jao-eww-session) ;;; jao-eww-session.el ends here diff --git a/lib/net/jao-frm.el b/lib/net/jao-frm.el deleted file mode 100644 index 2658687..0000000 --- a/lib/net/jao-frm.el +++ /dev/null @@ -1,222 +0,0 @@ -;;; jao-frm.el --- use frm to show mailbox - -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2019, 2020 - -;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> -;; Keywords: mail - -;; This file 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, or (at your option) -;; any later version. - -;; This file 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 GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Little hack to see the contents of your mailbox using GNU mailutils' -;; `frm' program. -;; -;; Just put (require 'jao-frm) in your .emacs, and M-x jao-frm will pop up a -;; new window with your mailbox contents (from and subject) as -;; printed by frm. In this buffer, use `n' and `p' to move, `q' to close -;; the window. `g' will call Gnus. -;; - -;;; Code: - -;;;; Customisation: - -(defgroup jao-frm nil - "Frm-base mailbox checker" - :group 'mail - :prefix "jao-frm-") - -(defcustom jao-frm-exec-path "frm" - "frm executable path" - :group 'jao-frm - :type 'file) - -(defcustom jao-frm-mail-command 'gnus - "Emacs function to invoke when `g' is pressed on an frm buffer." - :group 'jao-frm - :type 'symbol) - -(defcustom jao-frm-mailboxes nil - "List of mailboxes to check, or directory containing them." - :group 'jao-frm - :type '(choice directory (repeat file))) - -(defface jao-frm-mailno-face '((t (:foreground "dark slate grey"))) - "Face for the mail number." - :group 'jao-frm) - -(defface jao-frm-from-face '((t (:foreground "slate grey"))) - "Face for From: header." - :group 'jao-frm) - -(defface jao-frm-subject-face '((t (:foreground "slate blue"))) - "Face for Subject: header." - :group 'jao-frm) - -(defface jao-frm-mailbox-face '((t (:bold t :weight bold))) - "Face for mailbox name." - :group 'jao-frm) - -;;;; Mode: - -(defvar jao-frm-mode-map - (let ((map (make-keymap))) - (suppress-keymap map) - (define-key map [?q] 'jao-frm-delete-window) - (define-key map [?n] 'next-line) - (define-key map [?p] 'previous-line) - (define-key map [?r] 'jao-frm) - (define-key map [?g] (lambda () - (interactive) - (funcall jao-frm-mail-command))) - (define-key map [(control k)] 'jao-frm-delete-message) - map)) - -(setq jao-frm-font-lock-keywords - '(("^[^ :]+:" . 'jao-frm-mailbox-face) - ("^\\([ 0-9]+\\):\t+\\([^\t]+\\)\t+\\([^\n]+$\\)" - (1 'jao-frm-mailno-face) - (2 'jao-frm-from-face) - (3 'jao-frm-subject-face)))) - -(defvar jao-frm-mode-syntax-table - (let ((st (make-syntax-table))) - st)) - -(defun jao-frm-mode () - "Major mode for displaying frm output." - (interactive) - (kill-all-local-variables) - (buffer-disable-undo) - (use-local-map jao-frm-mode-map) - (set (make-local-variable 'font-lock-defaults) - '(jao-frm-font-lock-keywords)) - (set (make-local-variable 'truncate-lines) t) - (set (make-local-variable 'kill-whole-line) t) - (set (make-local-variable 'next-line-add-newlines) nil) - (setq major-mode 'jao-frm-mode) - (setq mode-name "frm") - (read-only-mode 1) - (goto-char 1)) - -;;;; Mode commands: -(defvar jao-frm-last-config nil) - -(defun jao-frm-delete-window () - "Delete frm window and restore last win config" - (interactive) - (if (and (consp jao-frm-last-config) - (window-configuration-p (car jao-frm-last-config))) - (progn - (set-window-configuration (car jao-frm-last-config)) - (goto-char (cadr jao-frm-last-config)) - (setq jao-frm-last-config nil)) - (bury-buffer))) - -(defun jao-frm-delete-message () - "Delete message at point" - (interactive) - (when (eq (current-buffer) (get-buffer "*frm*")) - (beginning-of-line) - (when (search-forward-regexp "^ +\\([0-9]+\\):" nil t) - (let ((mn (string-to-number (match-string 1)))) - (when (y-or-n-p (format "Delete message number %d? " mn)) - (read-only-mode -1) - (shell-command (format "echo 'd %d'|mail" mn) t) - (jao-frm) - (when (= (point-max) (point-min)) - (jao-frm-delete-window) - (message "Mailbox is empty"))))))) - -;;;; Activate frm: -(defun jao-frm-mbox-mails (mbox) - (let ((no (ignore-errors - (substring - (shell-command-to-string (format "frm -s n %s|wc -l" mbox)) - 0 -1)))) - (if (stringp no) (string-to-number no) 0))) - -(defun jao-frm-mail-number () - (let ((no 0)) - (dolist (b (jao-frm-mboxes) no) (setq no (+ no (jao-frm-mbox-mails b)))))) - -(defun jao-frm-default-count-formatter (m n) - (format "%s: %s" (file-name-sans-extension (file-name-nondirectory m)) n)) - -(defun jao-frm-mail-counts (fmt) - (let ((fmt (or fmt 'jao-frm-default-count-formatter))) - (remove nil - (mapcar (lambda (m) - (let ((n (jao-frm-mbox-mails m))) - (unless (zerop n) (funcall fmt m n)))) - (jao-frm-mboxes))))) - -(defun jao-frm-display-mailbox (mbox) - (when (not (zerop (jao-frm-mbox-mails mbox))) - (insert (or (file-name-nondirectory mbox) mbox) ":\n\n") - (apply 'call-process - `(,jao-frm-exec-path nil ,(current-buffer) nil - "-s" "n" "-n" "-t" ,@(and mbox (list mbox)))) - (newline 2))) - -(defun jao-frm-mboxes () - (cond ((null jao-frm-mailboxes) (list (getenv "MAIL"))) - ((listp jao-frm-mailboxes) jao-frm-mailboxes) - ((stringp jao-frm-mailboxes) - (if (file-directory-p jao-frm-mailboxes) - (directory-files jao-frm-mailboxes t "^[^.]") - (list jao-frm-mailboxes))) - (t (error "Error in mbox specification. Check `jao-frm-mailboxes'")))) - -;;;###autoload -(defun jao-frm () - "Run frm." - (interactive) - (let ((fbuff (get-buffer-create "*frm*")) - (inhibit-read-only t)) - (if (not (eq fbuff (current-buffer))) - (setq jao-frm-last-config - (list (current-window-configuration) (point-marker)))) - (with-current-buffer fbuff - (delete-region (point-min) (point-max)) - (mapc 'jao-frm-display-mailbox (jao-frm-mboxes)) - (unless (eq major-mode 'jao-frm-mode) - (jao-frm-mode)) - (goto-char (point-min)) - (if (= (point-min) (point-max)) - (message "Mailbox is empty.") - (pop-to-buffer fbuff)) - (when (and (boundp 'display-time-mode) display-time-mode) - (display-time-update))))) - -;;;###autoload -(defun jao-frm-show-mail-numbers (&optional fmt) - (interactive) - (let ((counts (jao-frm-mail-counts fmt))) - (message (if counts (mapconcat 'identity counts ", ") "No mail")))) - -;;;###autoload -(defun jao-frm-mail-string () - (let ((counts (jao-frm-mail-counts - (lambda (m n) - (let ((m (substring (file-name-nondirectory m) 0 1))) - (format "%s%s" (capitalize m) n)))))) - (mapconcat 'identity counts " "))) - -(provide 'jao-frm) - -;;; jao-frm.el ends here diff --git a/lib/net/jao-notmuch-gnus.el b/lib/net/jao-notmuch-gnus.el index e18c5a1..9b408c2 100644 --- a/lib/net/jao-notmuch-gnus.el +++ b/lib/net/jao-notmuch-gnus.el @@ -1,6 +1,6 @@ ;;; jao-notmuch-gnus.el --- notmuch-gnus interoperability -*- lexical-binding: t; -*- -;; Copyright (C) 2022 jao +;; Copyright (C) 2022, 2024, 2025, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: mail @@ -28,7 +28,6 @@ (require 'ol-gnus) (require 'notmuch-show) - ;;; Tagging in notmuch from Gnus buffers (defun jao-notmuch-gnus--notmuch-id (id) @@ -53,7 +52,7 @@ "Interactively add or remove tags to the current message." (interactive) (let* ((id (or id (jao-notmuch-gnus-message-id))) - (current (unless tags (jao-notmuch-gnus-message-tags id))) + (current (or tags (jao-notmuch-gnus-message-tags id))) (prompt (format "Change tags %s" (string-join current "/"))) (tags (or tags (notmuch-read-tag-changes current prompt)))) (notmuch-tag (concat "id:" id) tags) @@ -63,9 +62,14 @@ (defun jao-notmuch-gnus-show-tags () "Display in the echo area the tags of the current message." (interactive) - (when-let (id (jao-notmuch-gnus-message-id)) + (when-let* ((id (jao-notmuch-gnus-message-id))) (message "%s" (string-join (jao-notmuch-gnus-message-tags id) " ")))) +(jao-transient-major-mode+ gnus-summary + ["Tags" + ("s" "show message tags" jao-notmuch-gnus-show-tags) + ("t" "tag message" jao-notmuch-gnus-tag-message)]) + (defun jao-notmuch-gnus-toggle-tags (tags &optional id current) "Toggle the given TAGS list for the current Gnus message." (let* ((id (or id (jao-notmuch-gnus-message-id))) @@ -77,9 +81,9 @@ (message "New tags: %s" (jao-notmuch-gnus-message-tags id)))) (defun jao-notmuch-gnus-tag-mark () - "Remove the new tag for an article when it's marked as seen by Gnus." - (when-let (id (jao-notmuch-gnus-message-id t)) - (jao-notmuch-gnus-tag-message id '("-new") t))) + "Remove the new and unread tags for an article when it's marked as seen by Gnus." + (when-let* ((id (jao-notmuch-gnus-message-id t))) + (jao-notmuch-gnus-tag-message id '("-new" "-unread") t))) (add-hook 'gnus-mark-article-hook #'jao-notmuch-gnus-tag-mark) @@ -100,16 +104,50 @@ (add-hook 'gnus-summary-article-move-hook #'jao-notmuch-gnus-tag-on-move) (add-hook 'gnus-summary-article-expire-hook #'jao-notmuch-gnus-tag-on-move)) - -;;;; Displaying search results in Gnus +;;; Gnus search using notmuch + +(require 'gnus-search) + +(add-to-list 'gnus-search-expandable-keys "list") + +(defclass gnus-search-jao-notmuch (gnus-search-notmuch) ()) + +(cl-defmethod gnus-search-indexed-search-command + ((engine gnus-search-jao-notmuch) (qstring string) query &optional groups) + (let* ((limit (alist-get 'limit query)) + (thread (alist-get 'thread query)) + (qs (cond (thread + (format "thread:\"{%s}\"" + (thread-last (string-replace "\"" "\"\"" qstring) + (string-replace "<" "") + (string-replace ">" "")))) + (groups + (let ((gs (mapconcat 'gnus-group-short-name groups "|"))) + (format "(%s) and folder:/%s/" qstring gs))) + (t qstring)))) + (with-slots (switches config-file) engine + `(,(format "--config=%s" config-file) "search" "--output=files" + ,@(unless thread '("--duplicate=1")) + ,@(when limit (list (format "--limit=%d" limit))) + ,@switches + ,qs)))) + + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-jao-notmuch) + (expr (head list))) + (message "List query: %s" expr) + (format "List:%s" (gnus-search-transform-expression engine (cdr expr)))) + + +;;; Displaying search results in Gnus (defvar jao-notmuch-gnus-server "nnml" "Name of the target Gnus server, e.g. nnml+mail.") -(defvar jao-notmuch-gnus-mail-directory (expand-file-name "~/.emacs.d/gnus/Mail") +(defvar jao-notmuch-gnus-mail-directory (expand-file-name "~/var/mail/gnus") "Directory where Gnus stores its mail.") -(defvar jao-notmuch-gnus-leafnode-directory (expand-file-name "~/var/news") +(defvar jao-notmuch-gnus-leafnode-directory (expand-file-name "~/var/mail/news") "Directory where leafnode stores its messages as seen by notmuch.") (defun jao-notmuch-gnus-file-to-group (file &optional maildir newsdir) @@ -162,10 +200,16 @@ Example: (msg-id (when msg-id (replace-regexp-in-string "^id:" "" msg-id)))) (if (and group msg-id) (org-gnus-follow-link group msg-id) - (message "Couldn't get relevant infos for switching to Gnus.")))) + (message "Couldn't get relevant info for switching to Gnus.")))) + +(defun jao-notmuch-gnus-engine (prefix config) + (let ((prefix (file-name-as-directory (expand-file-name prefix "~"))) + (config (expand-file-name config gnus-home-directory))) + `(gnus-search-engine gnus-search-notmuch + (remove-prefix ,prefix) + (config-file ,config)))) - -;;;; Org links +;;; Org links (defun jao-notmuch-gnus--fname (id) (let ((cmd (format "notmuch search --output=files id:%s" id))) (car (split-string (shell-command-to-string cmd))))) @@ -176,12 +220,12 @@ Example: (org-gnus-follow-link group id))) (defun jao-notmuch-gnus-org-store () - (when-let (d (or (when (derived-mode-p 'notmuch-show-mode 'notmuch-tree-mode) - (cons (notmuch-show-get-message-id) - (notmuch-show-get-subject))) - (when (derived-mode-p 'gnus-summary-mode 'gnus-article-mode) - (cons (jao-notmuch-gnus-message-id) - (gnus-summary-article-subject))))) + (when-let* ((d (or (when (derived-mode-p 'notmuch-show-mode 'notmuch-tree-mode) + (cons (notmuch-show-get-message-id) + (notmuch-show-get-subject))) + (when (derived-mode-p 'gnus-summary-mode 'gnus-article-mode) + (cons (jao-notmuch-gnus-message-id) + (gnus-summary-article-subject)))))) (org-link-store-props :type "mail" :link (concat "mail:" (car d)) :description (concat "Mail: " (cdr d))))) @@ -193,21 +237,19 @@ Example: (org-link-set-parameters "gnus" :store #'ignore) (org-link-set-parameters "notmuch" :store #'ignore) - -;;;; consult-notmuch +;;; tags and flags -(with-eval-after-load "consult-notmuch" - (defun jao-notmuch-gnus--open-candidate (candidate) - "Open a notmuch-search completion candidate email in Gnus." - (message "candidate: %S" candidate) - (jao-notmuch-gnus-goto-message (consult-notmuch--thread-id candidate))) +(defun jao-notmuch-gnus-flag-current (&rest _) + (jao-notmuch-gnus-tag-message nil '("+flagged") t)) - (defun jao-gnus-consult-notmuch () - "Run a consult-notmuch query that opens candidates in Gnus." - (interactive) - (jao-notmuch-gnus--open-candidate (consult-notmuch--search))) +(defun jao-notmuch-gnus-unflag-current (&rest _) + (jao-notmuch-gnus-tag-message nil '("-flagged") t)) - (consult-customize jao-gnus-consult-notmuch :preview-key 'any)) +(advice-add 'gnus-summary-tick-article-forward + :before #'jao-notmuch-gnus-flag-current) +(advice-add 'gnus-summary-mark-as-read-forward + :before #'jao-notmuch-gnus-unflag-current) +;;; . (provide 'jao-notmuch-gnus) ;;; jao-notmuch-gnus.el ends here diff --git a/lib/net/jao-notmuch.el b/lib/net/jao-notmuch.el index bd48e8f..154f0d5 100644 --- a/lib/net/jao-notmuch.el +++ b/lib/net/jao-notmuch.el @@ -1,6 +1,6 @@ -;;; jao-notmuch.el --- Extensions for notmuch -*- lexical-binding: t; -*- +;; jao-notmuch.el --- Extensions for notmuch -*- lexical-binding: t; -*- -;; Copyright (C) 2021, 2022 jao +;; Copyright (C) 2021, 2022, 2023, 2024, 2025, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: mail @@ -18,11 +18,9 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see <https://www.gnu.org/licenses/>. -;;; Commentary: +;; Extensions to vanilla notmuch, mostly for tree view -;; Extensions to vanilla notmuch, mostly for tree view - -;;; Code: +;;; require: (require 'outline) (require 'mm-decode) @@ -32,11 +30,11 @@ (require 'notmuch-tree) (require 'notmuch-show) - -;;;; Targetting the displayed message from the tree view + +;;; targetting the displayed message from the tree view (defvar-local jao-notmuch--tree-buffer nil) -(declare eww--url-at-point "eww") +(declare-function eww--url-at-point "eww") (defun jao-notmuch-goto-message-buffer (&optional and-click no-record) (interactive "P") @@ -54,12 +52,6 @@ (notmuch-tree-close-message-window) (notmuch-tree-show-message nil))) -(defun jao-notmuch-click-message-buffer () - (interactive) - (let ((b (current-buffer))) - (unless (eq 'url (jao-notmuch-goto-message-buffer t t)) - (pop-to-buffer b)))) - (defun jao-notmuch-tree--find-tree-buffer () (or jao-notmuch--tree-buffer (let ((mb (current-buffer))) @@ -77,7 +69,7 @@ (user-error "No tree view for this buffer"))) (defun jao-notmuch-tree--looking-at-message () - (when-let (id (plist-get (notmuch-tree-get-message-properties) :id)) + (when-let* ((id (plist-get (notmuch-tree-get-message-properties) :id))) (equal (concat "*notmuch-id:" id "*") (buffer-name (window-buffer notmuch-tree-message-window))))) @@ -87,7 +79,7 @@ (if (not (jao-notmuch-tree--looking-at-message)) (jao-notmuch-tree-show-or-scroll t) (if (notmuch-tree-scroll-message-window) - (jao-notmuch-tree-next nil) + (notmuch-tree-outline-next) (when (not (window-live-p notmuch-tree-message-window)) (notmuch-tree-show-message nil))))) @@ -113,7 +105,7 @@ (goto-char (point-min)) (let ((pos (point))) (while (setq pos (next-single-property-change pos 'w3m-href-anchor)) - (when-let ((url (get-text-property pos 'w3m-href-anchor))) + (when-let* ((url (get-text-property pos 'w3m-href-anchor))) (when (stringp url) (cl-pushnew url res :test #'string=)))) (seq-uniq res #'string=)))) @@ -125,13 +117,13 @@ (defun jao-notmuch-browse-urls (&optional external) (interactive "P") - (if-let ((urls (jao-notmuch-message-urls))) + (if-let* ((urls (jao-notmuch-message-urls))) (funcall (if external browse-url-secondary-browser-function #'browse-url) (completing-read "Browse URL: " urls)) (message "No URLs in this message"))) - -;;;; Navigating URLs + +;;; navigating URLs (require 'ffap) @@ -139,26 +131,26 @@ (interactive) (when (get-text-property (point) 'w3m-href-anchor) (goto-char (next-single-property-change (point) 'w3m-href-anchor))) - (if-let (pos (next-single-property-change (point) 'w3m-href-anchor)) + (if-let* ((pos (next-single-property-change (point) 'w3m-href-anchor))) (goto-char pos) (or (forward-button 1 nil t t) (ffap-next-guess)))) (defun jao-notmuch-show-previous-button () (interactive) - (if-let (pos (previous-single-property-change (point) 'w3m-href-anchor)) + (if-let* ((pos (previous-single-property-change (point) 'w3m-href-anchor))) (goto-char (previous-single-property-change pos 'w3m-href-anchor)) (or (backward-button 1 nil t t) (ffap-next-guess t)))) (defun jao-notmuch-show-ret () (interactive) - (when-let (url (or (get-text-property (point) 'w3m-href-anchor) - (thing-at-point-url-at-point))) + (when-let* ((url (or (get-text-property (point) 'w3m-href-anchor) + (thing-at-point-url-at-point)))) (browse-url url))) - -;;;; Toggling mime parts and images + +;;; toggling mime parts and images (defun jao-notmuch--toggle-mime () (save-excursion @@ -175,7 +167,7 @@ (jao-notmuch-goto-tree-buffer t))) (defun jao-notmuch--view-html () - "Open the text/html part of the current message using `notmuch-show-view-part'." + "Open the text/html part of current message using `notmuch-show-view-part'." (interactive) (save-excursion (goto-char @@ -194,7 +186,7 @@ (let* ((b notmuch-tree-message-buffer) (show (not (buffer-local-value 'jao-notmuch--showing-images b))) (mm-text-html-renderer 'shr) - (shr-blocked-images (unless show shr-blocked-images)) + ;; (shr-blocked-images (unless show shr-blocked-images)) (shr-inhibit-images (not show)) (notmuch-show-text/html-blocked-images (unless show notmuch-show-text/html-blocked-images)) @@ -207,40 +199,46 @@ (defun jao-notmuch-toggle-images () (interactive) - (cond ((eq mm-text-html-renderer 'w3m) - (when (fboundp 'jao-notmuch--w3m-toggle-images) - (jao-notmuch--w3m-toggle-images))) + (cond ((memq mm-text-html-renderer '(w3m jao-w3m-html-renderer)) + (when (fboundp 'jao-notmuch--w3m-toggle-images) + (jao-notmuch--w3m-toggle-images))) (window-system (jao-notmuch--shr-toggle-images)) - (t (with-current-buffer notmuch-tree-message-buffer - (jao-notmuch--view-html))))) + (notmuch-tree-message-buffer + (if nil ;;(fboundp 'jao-open-in-x-frame) + (let ((w (get-buffer-window notmuch-tree-message-buffer))) + (jao-open-in-x-frame (window-width w) (window-height w)) + (jao-notmuch--shr-toggle-images) + (delete-window)) + (with-current-buffer notmuch-tree-message-buffer + (jao-notmuch--view-html)))))) - -;;;; Keeping track of unread messages in current tree view +;;; header and mode lines with thread message counts (defun jao-notmuch--looking-at-new-p (&optional p) - (when-let (ts (if p (plist-get p :tags) (notmuch-show-get-tags))) + (when-let* ((ts (if p (plist-get p :tags) (notmuch-show-get-tags)))) (or (member "unread" ts) (member "new" ts)))) (defsubst jao-notmuch-tree--first-p (&optional msg) (plist-get (or msg (notmuch-tree-get-message-properties)) :first)) -(defun jao-notmuch--message-counts (&optional thread) - (let ((cnt) (total 0) (match 0) (msg)) - (save-excursion - (if thread - (while (and (not (jao-notmuch-tree--first-p)) - (zerop (forward-line -1)))) - (goto-char (point-min))) - (while (and (setq msg (notmuch-tree-get-message-properties)) - (or (not cnt) - (not thread) - (not (jao-notmuch-tree--first-p msg)))) - (unless cnt (setq cnt 0)) - (setq total (1+ total)) - (when (plist-get msg :match) (setq match (1+ match))) - (when (jao-notmuch--looking-at-new-p msg) (setq cnt (1+ cnt))) - (forward-line 1))) - (when cnt (list total match cnt)))) +(defun jao-notmuch--message-counts (tree-buffer &optional thread) + (with-current-buffer tree-buffer + (let ((cnt) (total 0) (match 0) (msg)) + (save-excursion + (if thread + (while (and (not (jao-notmuch-tree--first-p)) + (zerop (forward-line -1)))) + (goto-char (point-min))) + (while (and (setq msg (notmuch-tree-get-message-properties)) + (or (not cnt) + (not thread) + (not (jao-notmuch-tree--first-p msg)))) + (unless cnt (setq cnt 0)) + (setq total (1+ total)) + (when (plist-get msg :match) (setq match (1+ match))) + (when (jao-notmuch--looking-at-new-p msg) (setq cnt (1+ cnt))) + (forward-line 1))) + (when cnt (list total match cnt))))) (defvar jao-notmuch-header-line-format "%Q [%N / %M / %T] %n / %m / %t") @@ -249,186 +247,159 @@ `((?Q . ,query) (?T . ,total) (?N . ,new) (?M . ,match) (?t . ,ttotal) (?n . ,tnew) (?m . ,tmatch)))) -(defun jao-notmuch--update-header-line (mb) - (let* ((n (or (jao-notmuch--message-counts) '(0 0 0))) - (nc (append n (or (jao-notmuch--message-counts t) '(0 0 0)))) - (q (buffer-name))) - (with-current-buffer mb +(defun jao-notmuch--format-header-line (tree-buffer buffer subject) + (let* ((n (jao-notmuch--message-counts tree-buffer)) + (nc (jao-notmuch--message-counts tree-buffer t))) + (with-current-buffer buffer (when (derived-mode-p 'notmuch-show-mode) - (let* ((s (thread-last (notmuch-show-get-subject) - (notmuch-show-strip-re) - (notmuch-sanitize))) + (let* ((nc (append (or n '(0 0 0)) (or nc '(0 0 0)))) + (q (if (string= tree-buffer subject) "" tree-buffer)) (c (apply 'jao-notmuch--format-counts q nc)) - (n (- (window-width) 3 (string-width s) (string-width c))) - (s (if (< n 0) (substring s 0 (- n 4)) s)) - (n (if (< n 0) 5 (1+ n)))) - (setq-local header-line-format - (concat " " s (make-string n ? ) c))))))) - -(defun jao-notmuch-tree--find-update-header-line (&rest _args) - (when-let ((mb (if (derived-mode-p 'notmuch-show-mode) - (current-buffer) - (window-buffer notmuch-tree-message-window)))) - (seq-find (lambda (b) - (with-current-buffer b - (and (derived-mode-p 'notmuch-tree-mode) - (or (null notmuch-tree-message-buffer) - (eq notmuch-tree-message-buffer mb)) - (jao-notmuch--update-header-line mb)))) - (buffer-list)))) - -(add-hook 'notmuch-after-tag-hook #'jao-notmuch-tree--find-update-header-line) -(add-hook 'notmuch-show-hook #'jao-notmuch-tree--find-update-header-line) - - -;;;; Outline mode for tree view - -(defun jao-notmuch-tree--msg-prefix (msg) - (insert (propertize (if (plist-get msg :first) "> " " ") 'display " "))) - -(defun jao-notmuch-tree--mode-setup () - (setq-local outline-regexp "^> \\|^En") - (outline-minor-mode t)) - -(defun jao-notmuch-tree-hide-others (&optional and-show) - (interactive) - (outline-hide-body) - (outline-show-entry) - (when and-show (notmuch-tree-show-message nil))) - -(defun jao-notmuch-tree--next (prev thread no-exit &optional ignore-new) - (let ((line-move-ignore-invisible nil)) - (cond ((and (not ignore-new) (jao-notmuch--looking-at-new-p))) - (thread - (notmuch-tree-next-thread prev) - (unless (or (not (notmuch-tree-get-message-properties)) - (jao-notmuch--looking-at-new-p)) - (notmuch-tree-matching-message prev (not no-exit)))) - (t (notmuch-tree-matching-message prev (not no-exit))))) - (when (notmuch-tree-get-message-id) - (jao-notmuch-tree-hide-others t)) - (when prev (forward-char 2))) - -(defvar jao-notmuch-tree--prefix-map - (let ((m (make-keymap "Thread operations"))) - (define-key m (kbd "TAB") #'outline-cycle) - (define-key m (kbd "t") #'outline-toggle-children) - (define-key m (kbd "s") #'outline-show-entry) - (define-key m (kbd "S") #'outline-show-all) - (define-key m (kbd "h") #'outline-hide-entry) - (define-key m (kbd "H") #'outline-hide-body) - (define-key m (kbd "o") #'jao-notmuch-tree-hide-others) - (define-key m (kbd "n") #'outline-hide-other) - m)) - -(defun jao-notmuch-tree-outline-setup (&optional prefix) - (define-key notmuch-tree-mode-map (kbd (or prefix "T")) - jao-notmuch-tree--prefix-map) - (define-key notmuch-tree-mode-map (kbd "TAB") #'outline-cycle) - (define-key notmuch-tree-mode-map (kbd "M-TAB") #'outline-cycle-buffer) - (add-hook 'notmuch-tree-mode-hook #'jao-notmuch-tree--mode-setup) - (advice-add 'notmuch-tree-insert-msg :before #'jao-notmuch-tree--msg-prefix)) - -(defun jao-notmuch-tree-next (thread &optional no-exit) - "Next message or thread in forest, taking care of thread visibility." - (interactive "P") - (jao-notmuch-tree--next nil thread no-exit)) - -(defun jao-notmuch-tree-next-thread (&optional exit) - "Next thread in forest, taking care of thread visibility." - (interactive "P") - (jao-notmuch-tree--next nil t exit)) - -(defun jao-notmuch-tree-previous (thread) - "Previous message or thread in forest, taking care of thread visibility." - (interactive "P") - (jao-notmuch-tree--next t thread t)) - -(defun jao-notmuch-tree-previous-thread (&optional exit) - "Previous thread in forest, taking care of thread visibility." - (interactive "P") - (jao-notmuch-tree--next t t exit)) - - -;;;; Updating the tree window after insertion - -(defun jao-notmuch--tree-sentinel (proc &rest _) - (when (eq (process-status proc) 'exit) - (jao-notmuch-tree-hide-others))) - -(defun jao-notmuch-tree-setup (&optional prefix) - "Set up display of trees, with PREFIX key for outline commands." - (jao-notmuch-tree-outline-setup prefix) - (advice-add 'notmuch-tree-process-sentinel :after #'jao-notmuch--tree-sentinel)) - - -;;;; Tagging + (n (- (window-width) 2 (string-width subject) (string-width c))) + (subject (if (< n 0) (substring subject 0 n) subject)) + (n (if (< n 0) 2 (+ n 2)))) + (concat (when window-system " ") subject (make-string n ? ) c)))))) + +(defun jao-notmuch-message-header-line (subject) + (if-let* ((cb (buffer-name (current-buffer))) + (tb (seq-find (lambda (b) + (with-current-buffer b + (and (derived-mode-p 'notmuch-tree-mode) b))) + (buffer-list)))) + `((:eval + (jao-notmuch--format-header-line ,(buffer-name tb) ,cb ,subject))) + (concat " " subject))) + +(defun jao-notmuch--format-lighter () + (when (derived-mode-p 'notmuch-tree-mode) + (let* ((n (jao-notmuch--message-counts (current-buffer))) + (nc (jao-notmuch--message-counts (current-buffer) t)) + (nc (append (or n '(0 0 0)) (or nc '(0 0 0))))) + (apply 'jao-notmuch--format-counts "" nc)))) + +(define-minor-mode jao-notmuch-thread-info-mode "" + :lighter (:eval (format " %s" (jao-notmuch--format-lighter)))) + + +;;; tagging (defsubst jao-notmuch--has-tag (tag) (member tag (notmuch-tree-get-tags))) -(defun jao-notmuch-tag-jump-and-next (reverse) - (interactive "P") - (notmuch-tag-jump reverse) - (jao-notmuch-tree-next nil t)) - -(defun jao-notmuch-tree--tag (tags reverse whole-thread) +(defun jao-notmuch-tree--tag (tags reverse) (let ((c (notmuch-tag-change-list tags reverse))) - (if whole-thread (notmuch-tree-tag-thread c) (notmuch-tree-tag c)))) - -(defun jao-notmuch-tree--tag-and-next (tags reverse whole-thread) - (jao-notmuch-tree--tag tags reverse whole-thread) - (jao-notmuch-tree-next whole-thread t)) + (notmuch-tree-tag c))) + +(defun jao-notmuch-tree-tag-thread (tags reverse full) + (when full (notmuch-tree-thread-top)) + (let ((c (notmuch-tag-change-list tags reverse)) + (level (or (notmuch-tree-get-prop :level) 0)) + (go t)) + (while go + (notmuch-tree-tag c) + (forward-line) + (setq go (> (or (notmuch-tree-get-prop :level) 0) level))) + (when notmuch-tree-outline-mode + (ignore-errors (outline-show-branches)) + (notmuch-tree-outline-next)))) + +(defun jao-notmuch-tree--tag-and-next (tags reverse) + (jao-notmuch-tree--tag tags reverse) + (notmuch-tree-outline-next t)) (defun jao-notmuch-tree-toggle-delete () (interactive) (let ((undo (jao-notmuch--has-tag "deleted"))) - (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undo nil))) + (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undo))) -(defun jao-notmuch-tree-toggle-delete-thread () - (interactive) +(defun jao-notmuch-tree-toggle-delete-thread (full) + (interactive "P") (let ((undo (jao-notmuch--has-tag "deleted"))) - (jao-notmuch-tree--tag-and-next '("+deleted" "-new" "-unread") undo t))) + (jao-notmuch-tree-tag-thread '("+deleted" "-new" "-unread") undo full))) -(defun jao-notmuch-tree-read-thread (unread) +(defun jao-notmuch-tree-mark-all-read () + (interactive) + (when-let* ((q notmuch-tree-basic-query)) + (when (yes-or-no-p "Mark all messages as read? ") + (notmuch-tag q '("-new" "-unread"))))) + +(defun jao-notmuch-tree-read-thread (full) (interactive "P") - (jao-notmuch-tree--tag-and-next '("-unread" "-new") unread t)) + (jao-notmuch-tree-tag-thread '("-unread" "-new") nil full)) (defun jao-notmuch-tree-toggle-flag () (interactive) (let ((tags (if (jao-notmuch--has-tag "flagged") '("-flagged") '("-unread" "-new" "-deleted" "+flagged")))) - (jao-notmuch-tree--tag-and-next tags nil nil))) + (jao-notmuch-tree--tag-and-next tags nil))) (defun jao-notmuch-tree-toggle-spam () (interactive) (let ((tags (if (jao-notmuch--has-tag "spam") '("-spam") '("-unread" "-new" "+spam")))) - (jao-notmuch-tree--tag-and-next tags nil nil))) + (jao-notmuch-tree--tag-and-next tags nil))) (defun jao-notmuch-tree-reset-tags () (interactive) (let ((tags (plist-get (notmuch-tree-get-message-properties) :orig-tags))) - (jao-notmuch-tree--tag tags nil nil) - (jao-notmuch-tree--next nil nil t t))) + (jao-notmuch-tree--tag tags nil))) - -;;;; Results formatters +(defvar jao-notmuch--shared-tags + '("new" "unread" "flagged" "signed" "sent" "attachment" "forwarded" "inbox" + "encrypted" "gmane" "gnus" "feeds" "rss" "mce" "trove" "prog" "emacs")) -(defun jao-notmuch-format-tags (fmt msg) - (let ((ts (thread-last (notmuch-tree-format-field "tags" "%s" msg) - (split-string) - (seq-sort-by #'length #'<)))) - (format-spec fmt `((?s . ,(mapconcat #'identity ts " ")))))) +(defun jao-notmuch-subtags (tag &rest excl) + (let* ((cmd (concat "notmuch search --output=tags tag:" tag)) + (ts (split-string (shell-command-to-string cmd)))) + (seq-difference ts (append jao-notmuch--shared-tags (cons tag excl))))) + +;;; fcc +(defvar jao-notmuch-tags-not-inherited + '("attachment" "sent" "new" "trove" "flagged" "drivel" "replied")) -(defun jao-notmuch-tree-and-subject (fmt msg) +(defvar jao-notmuch-sent-dir "sent") + +(defun jao-notmuch-mua--inherited-fcc () + (let* ((tags (seq-difference (notmuch-show-get-tags) + jao-notmuch-tags-not-inherited)) + (tagstr (mapconcat (lambda (s) (concat "+" s)) tags " ")) + (fcc (concat jao-notmuch-sent-dir " " tagstr " -new +sent")) + (fcc-dirs (assoc-delete-all ".*" (copy-alist notmuch-fcc-dirs)))) + (append fcc-dirs `((".*" . ,fcc))))) + +(defun jao-notmuch-mua-new-reply (fun &rest args) + (let ((notmuch-fcc-dirs (jao-notmuch-mua--inherited-fcc))) + (apply fun args))) + +(advice-add 'notmuch-mua-new-reply :around #'jao-notmuch-mua-new-reply) + +;;; results formatters + +(defun jao-notmuch-cmp-tags (a b) + (or (> (length a) (length b)) (string-lessp a b))) + +(defun jao-notmuch-format-tags (fmt msg) + (if (> (window-width) 85) + (let ((ts (thread-last (notmuch-tree-format-field "tags" "%s" msg) + (split-string) + ;; (seq-sort-by #'length #'<) + (seq-sort #'jao-notmuch-cmp-tags)))) + (format-spec fmt `((?s . ,(mapconcat #'identity ts " "))))) + "")) + +(defun jao-notmuch-format-authors (threshold msg) + (let ((fmt (if (< (window-width) threshold) "%-15s" "%-35s"))) + (notmuch-tree-format-field "authors" fmt msg))) + +(defun jao-notmuch-format-tree-and-subject (_fmt msg) (let ((tr (notmuch-tree-format-field "tree" " %s" msg)) - (sb (notmuch-tree-format-field "subject" " %s" msg))) + (sb (notmuch-tree-format-field "subject" " %s" msg)) + (fmt (format "%%>-%ds" (- (window-width) 45)))) (format-spec fmt `((?s . ,(concat tr sb)))))) -(defun jao-notmuch-msg-ticks (mails-rx msg) +(defun jao-notmuch-format-msg-ticks (mails-rx msg) (let ((headers (plist-get msg :headers))) (cond ((string-match-p mails-rx (or (plist-get headers :To) "")) (propertize " »" 'face 'notmuch-tree-match-tree-face)) @@ -437,4 +408,24 @@ (t " ")))) (provide 'jao-notmuch) +;;; org links +(defun jao-notmuch-id-file-name (id) + (let ((cmd (format "notmuch search --output=files id:%s" id))) + (car (split-string (shell-command-to-string cmd))))) + +(defun jao-notmuch-org-store () + (when-let* ((d (and (derived-mode-p '(notmuch-show-mode notmuch-tree-mode)) + (cons (notmuch-show-get-message-id) + (notmuch-show-get-subject))))) + (org-link-store-props :type "mail" + :link (concat "mail:" (car d)) + :description (concat "Mail: " (cdr d))))) + +(defun jao-notmuch-org-links () + (org-link-set-parameters "mail" + :follow #'notmuch-show + :store #'jao-notmuch-org-store) + (org-link-set-parameters "gnus" :store #'ignore) + (org-link-set-parameters "notmuch" :store #'ignore)) + ;;; jao-notmuch.el ends here diff --git a/lib/net/jao-r2e.el b/lib/net/jao-r2e.el new file mode 100644 index 0000000..f28b66b --- /dev/null +++ b/lib/net/jao-r2e.el @@ -0,0 +1,231 @@ +;;; jao-r2e.el --- List of rss2email subscriptions -*- lexical-binding: t; -*- + +;; Copyright (C) 2025, 2026 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <mail@jao.io> +;; Keywords: news + +;; 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 <https://www.gnu.org/licenses/>. + +(require 'multisession) +(require 'jao-url) + +(autoload 'View-quit "view") +(autoload 'eww-view-source "eww") +(autoload 'jao-notmuch-subtags "jao-notmuch") + +(defvar jao-r2e-command "r2e") +(defvar jao-r2e-confirm-toggle nil) + +(defconst jao-r2e--buffer "*r2e*") +(defun jao-r2e--buffer () + (with-current-buffer (get-buffer-create jao-r2e--buffer) + (unless (derived-mode-p 'jao-r2e-mode) + (jao-r2e-mode)) + (current-buffer))) + +(defvar jao-r2e-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + (define-key map [?q] 'bury-buffer) + (define-key map [?n] 'next-line) + (define-key map [?p] 'previous-line) + (define-key map [?N] 'jao-r2e-next) + (define-key map [?P] 'jao-r2e-prev) + (define-key map [?g] 'jao-r2e-list) + (define-key map [?s] 'jao-r2e-subscribe) + (define-key map [?t] 'jao-r2e-toggle) + (define-key map [?D] 'jao-r2e-delete) + (define-key map [?u] 'jao-r2e-recover) + (define-key map [?y] 'jao-r2e-kill-url) + (define-key map [?x] 'jao-r2e-list-subscribed) + map)) + +;;;###autoload +(defun jao-r2e-mode () + "A very simple mode to show the output of r2e commands." + (interactive) + (kill-all-local-variables) + (buffer-disable-undo) + (use-local-map jao-r2e-mode-map) + ;; (setq-local font-lock-defaults '(jao-r2e-font-lock-keywords)) + (setq-local truncate-lines t) + (setq-local next-line-add-newlines nil) + (setq major-mode 'jao-r2e-mode) + (setq mode-name "r2e") + (read-only-mode 1)) + +(defun jao-r2e--do (things &optional buffer) + "Execute a r2e command THINGS in the given BUFFER." + (let ((b (or buffer (pop-to-buffer (jao-r2e--buffer))))) + (let ((inhibit-read-only t) + (cmd (format "%s %s" jao-r2e-command things))) + (unless buffer + (with-current-buffer b (delete-region (point-min) (point-max)))) + (with-temp-message (format "Running: %s ...." cmd) + (shell-command cmd b)) + (unless buffer (read-only-mode 1))))) + +(defconst jao-r2e--feed-rx + "^\\([0-9]+\\): \\[\\( \\|\\*\\)\\] \\([^ ]+\\) (\\(.+\\) -> \\(.+\\))") + +(defun jao-r2e--feed-at-point () + (beginning-of-line) + (when-let* ((m (looking-at jao-r2e--feed-rx))) + (list (match-string 1) + (match-string 3) + (string= "*" (match-string 2)) + (match-string 4) + (match-string 5)))) + +(defun jao-r2e () + (interactive) + (pop-to-buffer (jao-r2e--buffer)) + (when (looking-at-p "^$") + (jao-r2e-list))) + +(defun jao-r2e-list () + (interactive) + (jao-r2e--do "list")) + +(defun jao-r2e-list-subscribed (arg) + "Show only subscribed (unsubscribed with arg) feeds." + (interactive "P") + (jao-r2e-list) + (let ((inhibit-read-only t)) + (flush-lines (if arg ".*\\[\\*\\].*" ".*\\[ \\].*")))) + +(defun jao-r2e--srx (opp) + (when-let* ((f (jao-r2e--feed-at-point))) + (let ((a (if opp (not (caddr f)) (caddr f)))) + (format "^[0-9]+: \\[%s\\] " (if a "\\*" " "))))) + +(defun jao-r2e-next (opp) + "Next feed with the same (or opposite) status." + (interactive "P") + (when-let* ((rx (jao-r2e--srx opp))) + (forward-line) + (when (re-search-forward rx nil t) + (beginning-of-line)))) + +(defun jao-r2e-prev (opp) + "Previous feed with the same (or opposite) status." + (interactive "P") + (when-let* ((rx (jao-r2e--srx opp))) + (when (re-search-backward rx nil t) + (beginning-of-line)))) + +(defun jao-r2e-kill-url () + "Copy as kill the URL of the feed at point." + (interactive) + (let ((url (cadddr (jao-r2e--feed-at-point)))) + (if (not url) + (error "No feed at point") + (kill-new url) + (message "%s" url)))) + +(defun jao-r2e-toggle () + (interactive) + (let ((f (jao-r2e--feed-at-point))) + (unless f (error "No feed at point")) + (let ((p (point)) + (no (car f)) + (name (cadr f)) + (act (if (caddr f) "pause" "unpause"))) + (when (or (not jao-r2e-confirm-toggle) + (yes-or-no-p (format "%s '%s'? " act name))) + (with-temp-buffer + (jao-r2e--do (format "%s %s" act no) (current-buffer))) + (jao-r2e-list) + (goto-char p))))) + +(define-multisession-variable jao-r2e-deleted-feeds '() + "List of rss2email feeds deleted at some point.") + +(defun jao-r2e--deleted () (multisession-value jao-r2e-deleted-feeds)) + +(defun jao-r2e-delete () + "Delete feed at point. Use `jao-r2e-recover' to undelete." + (interactive) + (let ((f (jao-r2e--feed-at-point))) + (unless f (error "No feed at point")) + (let ((p (point)) + (no (car f)) + (entry (cdr f))) + (when (yes-or-no-p (format "Delete feed '%s'" (car entry))) + (setf (multisession-value jao-r2e-deleted-feeds) + (cons entry (remove entry (jao-r2e--deleted)))) + (with-temp-buffer + (jao-r2e--do (format "delete %s" no) (current-buffer))) + (jao-r2e-list) + (goto-char p))))) + +(defun jao-r2e-recover () + (interactive) + (when (seq-empty-p (jao-r2e--deleted)) + (error "No feeds recoverable at this point.")) + (let* ((entries (jao-r2e--deleted)) + (feed (completing-read "Recover feed: " entries))) + (when-let* ((ps (assoc feed entries)) + (url (caddr ps)) + (mail (car (last ps))) + (cat (when (string-match "feeds\\.\\(.+\\)@localhost" mail) + (match-string 1 mail)))) + (jao-r2e-subscribe (list url feed) cat t) + (setf (multisession-value jao-r2e-deleted-feeds) (remove ps entries))))) + +(defun jao-r2e--find-url () + (save-excursion + (when (derived-mode-p 'w3m-mode 'eww-mode) + (if (fboundp 'w3m-view-source) (w3m-view-source) (eww-view-source))) + (goto-char (point-min)) + (when (re-search-forward + "type=\"application/\\(?:atom\\|rss\\)\\+xml\" +" nil t) + (let ((url (save-excursion + (when (re-search-forward + "href=\"\\([^\n\"]+\\)\"" nil t) + (match-string-no-properties 1)))) + (title (when (re-search-forward + "\\(?:title=\"\\([^\n\"]+\\)\" +\\)" nil t) + (match-string-no-properties 1)))) + (when (string-match-p ".*\\*eww-source\\b.*" (buffer-name)) + (View-quit)) + (when url (cons url (or title ""))))))) + +(defun jao-r2e-subscribe (url &optional cat relist) + "Subscribe to a given RSS URL. If URL not given, look for it." + (interactive (list (or (jao-url-around-point) + (jao-r2e--find-url) + (read-string "Feed URL: ")))) + (let* ((url+title (ensure-list url)) + (url (car url+title)) + (title (cdr url+title))) + (unless url (error "No feeds found")) + (let ((url (if (string-match "^feed:" url) (substring url 5) url))) + (when (y-or-n-p (format "Subscribe to <%s>? " url)) + (let* ((name (read-string "Feed name: " title)) + (cats (cons "prog" (jao-notmuch-subtags "feeds"))) + (cat (completing-read "Category: " cats nil t cat)) + (sfmt (format "%%s add %s '%s' mail+feeds_%s@jao.io" name url cat))) + (with-temp-message "Subscribing..." + (shell-command-to-string (format sfmt "r2e")) + (when (not (string= jao-r2e-command "r2e")) + (shell-command-to-string (format sfmt jao-r2e-command)))) + (when (y-or-n-p "Retrieve feeds now? ") + (with-temp-message "Retrieving feed..." + (shell-command (format "%s run %s" jao-r2e-command name)))) + (when relist (jao-r2e-list))))))) + +(provide 'jao-r2e) +;;; jao-r2e.el ends here diff --git a/lib/net/jao-url.el b/lib/net/jao-url.el new file mode 100644 index 0000000..ac66cef --- /dev/null +++ b/lib/net/jao-url.el @@ -0,0 +1,45 @@ +;;; jao-url.el --- URL handling -*- lexical-binding: t; -*- + +;; Copyright (C) 2025 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <mail@jao.io> +;; Keywords: hypermedia + +;; 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 <https://www.gnu.org/licenses/>. + +(require 'shr) +(require 'ffap) +(require 'thingatpt) + +(defun jao-url-around-point (&optional current-url) + (or (and (fboundp 'w3m-anchor) (w3m-anchor)) + (shr-url-at-point nil) + (ffap-url-at-point) + (thing-at-point 'url) + (when current-url + (or (and (fboundp 'w3m-anchor) (w3m-anchor)) + (and (derived-mode-p 'eww-mode) (plist-get eww-data :url)))))) + + +(defun jao-url-email-url () + (save-excursion + (goto-char (point-min)) + (when (or (search-forward-regexp "^Via: h" nil t) + (search-forward-regexp "^URL:[\n ]h" nil t) + (and (search-forward-regexp "^Link$" nil t) + (not (beginning-of-line)))) + (jao-url-around-point)))) + +(provide 'jao-url) +;;; jao-url.el ends here diff --git a/lib/net/randomsig.el b/lib/net/randomsig.el index cb37694..e3c735b 100644 --- a/lib/net/randomsig.el +++ b/lib/net/randomsig.el @@ -1,6 +1,6 @@ -;;; randomsig.el --- insert a randomly selected signature +;;; randomsig.el --- insert a randomly selected signature -*- lexical-binding: t; -*- -;; Copyright (C) 2001, 2002, 2013, 2020, 2021 Hans-Jürgen Ficker +;; Copyright (C) 2001, 2002, 2013, 2020, 2021, 2024, 2026 Hans-Jürgen Ficker ;; Emacs Lisp Archive Entry ;; Author: Hans-Juergen Ficker <hj@backmes.de> @@ -277,8 +277,11 @@ You probably want to have a newline at the end of it." (defun randomsig-prompt (&optional prompt) ;; Prompt for a signature file. (let ((files (randomsig-files-to-list randomsig-files))) - (completing-read (if prompt prompt "signature: ") - (mapcar 'list files) nil t nil randomsig-history (car files)))) + (if (cdr files) + (completing-read (if prompt prompt "signature: ") + (mapcar 'list files) nil t nil + randomsig-history (car files)) + (car files)))) (defun randomsig-read-signatures-to-buffer (buffer-name &optional files) ;; read the signatures into the signature buffer @@ -305,7 +308,7 @@ You probably want to have a newline at the end of it." ;; get a list with file names of signature files (let ((sigfiles (randomsig-files-to-list files))) ;; Insert all files into the newly created buffer - (mapcar + (mapc (lambda (fname) (let ((pos (point-max))) @@ -345,10 +348,10 @@ You probably want to have a newline at the end of it." (defun randomsig-goto-signature () -;; This function is stolen fom message-goto signature. -;; Go to beginnig of the signature, and return t. -;; If there is no signature in current buffer, go to end of buffer, -;; and return nil. + ;; This function is stolen fom message-goto signature. + ;; Go to beginnig of the signature, and return t. + ;; If there is no signature in current buffer, go to end of buffer, + ;; and return nil. (goto-char (point-min)) (if (re-search-forward "^-- $" nil t) (progn @@ -380,30 +383,25 @@ Else a signature out of `randomsig-files' will be choosen." (randomsig-read-signatures-to-buffer randomsig-buffer-name files) (goto-char (point-min)) - (let '(count 0) 'selected - - ;; Count number of signatures - (while (search-forward-regexp randomsig-delimiter-pattern nil t) - (setq count (1+ count))) - - ;; Select random signature out out these - (setq selected (1+ (random count))) - (goto-char (point-min)) - (if (search-forward-regexp randomsig-delimiter-pattern nil t selected) - (forward-char)) - - ;; Cut signature and return it - (let '(here (point)) 'signature-string - - (if (not (search-forward-regexp randomsig-delimiter-pattern - nil t)) - (goto-char (point-max)) - (beginning-of-line)) - (setq signature-string - (concat randomsig-static-string - (buffer-substring here (point)))) - (kill-buffer randomsig-buffer-name) - signature-string)))) + (let ((count 0) (selected nil)) + ;; Count number of signatures + (while (search-forward-regexp randomsig-delimiter-pattern nil t) + (setq count (1+ count))) + ;; Select random signature out out these + (setq selected (1+ (random count))) + (goto-char (point-min)) + (if (search-forward-regexp randomsig-delimiter-pattern nil t selected) + (forward-char)) + ;; Cut signature and return it + (let ((here (point)) + (signature-string nil)) + (if (not (search-forward-regexp randomsig-delimiter-pattern nil t)) + (goto-char (point-max)) + (beginning-of-line)) + (setq signature-string + (concat randomsig-static-string (buffer-substring here (point)))) + (kill-buffer randomsig-buffer-name) + signature-string)))) (defun randomsig-replace-sig (arg) @@ -412,34 +410,31 @@ When called with prefix, read the filename of the signature-file that should be used" (interactive "P") (save-excursion - (randomsig-replace-signature (randomsig-signature (if arg (randomsig-prompt "read from signature-lib: ") randomsig-files))))) - - (defun randomsig-message-read-sig (arg) "Get the signature of current message and copy it to a file. If mark is active, get the marked region instead. When called with prefix, let the user edit the signature before saving" (interactive "P") (save-excursion - (let '(signature-string + (let ((signature-string (if (randomsig-mark-active-p) (buffer-substring (point) (mark)) (progn (if (randomsig-goto-signature) - (let `(here (point)) + (let ((here (point))) (goto-char (point-max)) (while (char-equal (char-before) 10) (backward-char)) (buffer-substring here (point))) - nil)))) + nil))))) (when signature-string (if arg (progn @@ -448,7 +443,6 @@ When called with prefix, let the user edit the signature before saving" (randomsig-edit signature-string)) (randomsig-write-signature signature-string)))))) - (defun randomsig-write-signature (signature-string) (set-buffer (find-file-noselect (expand-file-name @@ -462,14 +456,13 @@ When called with prefix, let the user edit the signature before saving" (save-buffer)) -(defun gnus/randomsig-summary-read-sig (arg) - "Get the signature of current message and copy it to a file" - (interactive "P") - (progn ;save-excursion - ;; FIXME: Doesn't return to summary buffer (save-excursion should do this) - (gnus-summary-select-article-buffer) - (randomsig-message-read-sig arg))) - +;; (defun gnus/randomsig-summary-read-sig (arg) +;; "Get the signature of current message and copy it to a file" +;; (interactive "P") +;; (progn ;save-excursion +;; ;; FIXME: Doesn't return to summary buffer (save-excursion should do this) +;; (gnus-summary-select-article-buffer) +;; (randomsig-message-read-sig arg))) (defun randomsig-search-sigfiles (&optional file) "Scan `randomsig-dir' and its subdirectories for regular files. @@ -486,7 +479,7 @@ If FILE is given, only FILE and its subdirectory will be searched." ;; unwanted... nil - (let '(path (expand-file-name file randomsig-dir)) + (let ((path (expand-file-name file randomsig-dir))) (if (file-directory-p path) (mapcan (lambda (f) (randomsig-search-sigfiles (if (string= file "") @@ -568,7 +561,7 @@ You most likely do not want to call `randomsig-edit-mode' directly. \\{randomsig-edit-mode-map}" (define-key randomsig-edit-mode-map - (kbd "C-c C-c") 'randomsig-edit-done)) + (kbd "C-c C-c") 'randomsig-edit-done)) ;;; Commands for randomsig-select-mode diff --git a/lib/net/signel.org b/lib/net/signel.org deleted file mode 100644 index 722069c..0000000 --- a/lib/net/signel.org +++ /dev/null @@ -1,546 +0,0 @@ -#+title: signel, a barebones signal chat on top of signal-cli -#+date: <2020-02-23 05:03> -#+filetags: emacs norss -#+PROPERTY: header-args :tangle yes :comments yes :results silent - -Unlike most chat systems in common use, [[https://signal.org][Signal]] lacks a decent emacs -client. All i could find was [[https://github.com/mrkrd/signal-msg][signal-msg]], which is able only to send -messages and has a readme that explicitly warns that its is /not/ a chat -application. Skimming over signal-msg's code i learnt about -[[https://github.com/AsamK/signal-cli][signal-cli]], a java-based daemon that knows how to send and receive -signal messages, and how to link to a nearby phone, or register new -users. And playing with it i saw that it can output its activities -formatted as JSON, and that offers (when run in daemon mode) a DBUS -service that can be used to send messages. - -Now, emacs knows how to run a process and capture its output handling -it to a filter function, and comes equipped with a JSON parser and -a set of built-in functions to talk to DBUS buses. - -So how about writing a simple Signal chat app for emacs? Let's call it -/signel/, and write it as [[https://gitlab.com/jaor/elibs/-/blob/master/net/signel.org][a blog post in literate org-mode]]. - -* Starting a process - -We are going to need a variable for our identity (telephone number), -and a list of contact names (until i discover how to get them directly -from signal-cli): - -#+begin_src emacs-lisp -(require 'cl-lib) - -(defvar signel-cli-user "+44744xxxxxx") -(defvar signel-contact-names '(("+447xxxxxxxx" . "john") - ("+346xxxxxxxx" . "anna"))) -#+end_src - -and a simple function to get a contact name given its telephone -number: - -#+begin_src emacs-lisp -(defun signel--contact-name (src) - (or (alist-get src signel-contact-names nil nil #'string-equal) src)) -#+end_src - -We are also going to need the path for our signal-cli executable - -#+begin_src emacs-lisp -(defvar signel-cli-exec "signal-cli") -#+end_src - -Starting the signal-cli process is easy: ~make-process~ provides all the -necessary bits. What we need is essentially calling - -#+begin_src shell -signal-cli -u +44744xxxxxx daemon --json -#+end_src - -associating to the process a buffer selected by the function -~signel--proc-buffer~ . While we are at it, we'll write also little -helpers for users of our API. - -#+begin_src emacs-lisp -(defun signel--proc-buffer () - (get-buffer-create "*signal-cli*")) - -(defun signel-signal-cli-buffer () - (get-buffer "*signal-cli*")) - -(defun signel-signal-cli-process () - (when-let ((proc (get-buffer-process (signel-signal-cli-buffer)))) - (and (process-live-p proc) proc))) -#+end_src - -#+begin_src emacs-lisp -(defun signel-start () - "Start the underlying signal-cli process if needed." - (interactive) - (if (signel-signal-cli-process) - (message "signal-cli is already running!") - (let ((b (signel--proc-buffer))) - (make-process :name "signal-cli" - :buffer b - :command `(,signel-cli-exec - "-u" - ,signel-cli-user - "daemon" "--json") - :filter #'signel--filter) - (message "Listening to signals!")))) -#+end_src - -* Parsing JSON - -We've told emacs to handle any ouput of the process to the function -~signel--filter~, which we're going to write next. This function will -receive the process object and its latest output as a string -representing a JSON object. Here's an example of the kind of outputs -that signal-cli emits: - -#+begin_src json :tangle no -{ - "envelope": { - "source": "+4473xxxxxxxx", - "sourceDevice": 1, - "relay": null, - "timestamp": 1582396178696, - "isReceipt": false, - "dataMessage": { - "timestamp": 1582396178696, - "message": "Hello there!", - "expiresInSeconds": 0, - "attachments": [], - "groupInfo": null - }, - "syncMessage": null, - "callMessage": null, - "receiptMessage": null - } -} -#+end_src - -Everything seems to be always inside ~envelope~, which contains objects -for the possible messages received. In the example above, we're -receiving a message from a /source/ contact. We can also receive -receipt messages, telling us whether our last message has been -received or read; e.g.: - -#+begin_src json :tangle no -{ - "envelope": { - "source": "+4473xxxxxxxx", - "sourceDevice": 1, - "relay": null, - "timestamp": 1582397117584, - "isReceipt": false, - "dataMessage": null, - "syncMessage": null, - "callMessage": null, - "receiptMessage": { - "when": 1582397117584, - "isDelivery": true, - "isRead": false, - "timestamps": [ - 1582397111524 - ] - } - } -} -#+end_src - -A bit confusingly, that delivery notification has a ~receiptMessage~, -but its ~isReceipt~ flag is set to ~false~. At other times, we get -~isReceipt~ but no ~receiptMessage~: - -#+begin_src json :tangle no -{ - "envelope": { - "source": "+346xxxxxxxx", - "sourceDevice": 1, - "relay": null, - "timestamp": 1582476539281, - "isReceipt": true, - "dataMessage": null, - "syncMessage": null, - "callMessage": null, - "receiptMessage": null - } -} -#+end_src - -It is very easy to parse JSON in emacs and extract signal-cli's -envelopes (and it's become faster in emacs 27, but the interface is a -bit different): - -#+begin_src emacs-lisp -(defun signel--parse-json (str) - (if (> emacs-major-version 26) - (json-parse-string str - :null-object nil - :false-object nil - :object-type 'alist - :array-type 'list) - (json-read-from-string str))) - -(defun signel--msg-contents (str) - (alist-get 'envelope (ignore-errors (signel--parse-json str)))) -#+end_src - -Here i am being old-school and opting to receive JSON dicitionaries as -alists (rather than hash maps, the default), and arrays as lists -rather than vectors just because lisps are lisps for a reason. I'm -also going to do some mild [[https://lispcast.com/nil-punning/][nil punning]], -hence the choice for null and false representations. - -Once the contents of the envelope is extracted, it's trivial (and -boring) to get into its components: - -#+begin_src emacs-lisp -(defun signel--msg-source (msg) (alist-get 'source msg)) - -(defun signel--msg-data (msg) - (alist-get 'message (alist-get 'dataMessage msg))) - -(defun signel--msg-timestamp (msg) - (if-let (msecs (alist-get 'timestamp msg)) - (format-time-string "%H:%M" (/ msecs 1000)) - "")) - -;; emacs 26 compat -(defun signel--not-false (x) - (and (not (eq :json-false x)) x)) - -(defun signel--msg-receipt (msg) - (alist-get 'receiptMessage msg)) - -(defun signel--msg-is-receipt (msg) - (signel--not-false (alist-get 'isReceipt msg))) - -(defun signel--msg-receipt-timestamp (msg) - (when-let (msecs (alist-get 'when (signel--msg-receipt msg))) - (format-time-string "%H:%M" (/ msecs 1000)))) - -(defun signel--msg-is-delivery (msg) - (when-let ((receipt (signel--msg-receipt msg))) - (signel--not-false (alist-get 'isDelivery msg)))) - -(defun signel--msg-is-read (msg) - (when-let ((receipt (signel--msg-receipt msg))) - (signel--not-false (alist-get 'isRead msg)))) -#+end_src - -* A process output filter - -We're almost ready to write our filter. It will: - -- For debugging purposes, insert the raw JSON string in the process - buffer. -- Parse the received JSON string and extract its envelope contents. -- Check wether it has a source and either message data or a receipt - timestamp. -- Dispatch to a helper function that will insert the data or - notification in a chat buffer. - -Or, in elisp: - -#+begin_src emacs-lisp -(defvar signel--line-buffer "") - -(defun signel--filter (proc str) - (signel--ordinary-insertion-filter proc str) - (let ((str (concat signel--line-buffer str))) - (if-let ((msg (signel--msg-contents str))) - (let ((source (signel--msg-source msg)) - (stamp (signel--msg-timestamp msg)) - (data (signel--msg-data msg)) - (rec-stamp (signel--msg-receipt-timestamp msg))) - (setq signel--line-buffer "") - (when source - (signel--update-chat-buffer source data stamp rec-stamp msg))) - (setq signel--line-buffer - (if (string-match-p ".*\n$" str) "" str))))) -#+end_src - -We've had to take care of the case when the filter receives input that -is not a complete JSON expression: in the case of signal-cli, that -only happens when we haven't seen yet an end of line. - -The function to insert the raw contents in the process buffer is -surprisingly hard to get right, but the emacs manual spells out a -reasonable implementation, which i just copied: - -#+begin_src emacs-lisp -(defun signel--ordinary-insertion-filter (proc string) - (when (and proc (buffer-live-p (process-buffer proc))) - (with-current-buffer (process-buffer proc) - (let ((moving (= (point) (process-mark proc)))) - (save-excursion - ;; Insert the text, advancing the process marker. - (goto-char (process-mark proc)) - (insert string) - (set-marker (process-mark proc) (point))) - (if moving (goto-char (process-mark proc))))))) -#+end_src - -* It's not an emacs app if it doesn't have a new mode - -With that out of the way, we just have to insert our data in an -appropriate buffer. We are going to associate a separate buffer to -each /source/, using for that its name: - -#+begin_src emacs-lisp -(defvar-local signel-user nil) - -(defun signel--contact-buffer (source) - (let* ((name (format "*%s" (signel--contact-name source))) - (buffer (get-buffer name))) - (unless buffer - (setq buffer (get-buffer-create name)) - (with-current-buffer buffer - (signel-chat-mode) - (setq-local signel-user source) - (insert signel-prompt))) - buffer)) -#+end_src - -where, as is often the case in emacs, we are going to have a dedicated -major mode for chat buffers, called ~signel-chat-mode~. For now, let's -keep it really simple (for the record, this is essentially a copy of -what ERC does for its erc-mode): - -#+begin_src emacs-lisp -(defvar signel-prompt ": ") - -(define-derived-mode signel-chat-mode fundamental-mode "Signal" - "Major mode for Signal chats." - (when (boundp 'next-line-add-newlines) - (set (make-local-variable 'next-line-add-newlines) nil)) - (setq line-move-ignore-invisible t) - (set (make-local-variable 'paragraph-separate) - (concat "\C-l\\|\\(^" (regexp-quote signel-prompt) "\\)")) - (set (make-local-variable 'paragraph-start) - (concat "\\(" (regexp-quote signel-prompt) "\\)")) - (setq-local completion-ignore-case t)) -#+end_src - -Note how, in ~signel--contact-buffer~, we're storing the user identity -associated with the buffer (its /source/) in a buffer-local variable -named ~signel-user~ that is set /after/ enabling ~signel-chat-mode~: order -here matters because the major mode activation cleans up the values of -any local variables previously set (i always forget that!). - -* And a customization group - -We're going to need a couple of new faces for the different parts of -inserted messages, so we'll take the chance to be tidy and introduce a -customization group: - -#+begin_src emacs-lisp -(defgroup signel nil "Signel") - -(defface signel-contact '((t :weight bold)) - "Face for contact names." - :group 'signel) - -(defface signel-timestamp '((t :foreground "grey70")) - "Face for timestamp names." - :group 'signel) - -(defface signel-notice '((t :inherit signel-timestamp)) - "Face for delivery notices." - :group 'signel) - -(defface signel-prompt '((t :weight bold)) - "Face for the input prompt marker." - :group 'signel) - -(defface signel-user '((t :foreground "orangered")) - "Face for sent messages." - :group 'signel) - -(defface signel-notification '((t :foreground "burlywood")) - "Face for notifications shown by tracking, when available." - :group 'signel) - -#+end_src - - -* Displaying incoming messages - -We have now almost all the ingredients to write -~signel--update-chat-buffer~, the function that inserts the received -message data into the chat buffer. Let's define a few little -functions to format those parts: - -#+begin_src emacs-lisp -(defun signel--contact (name) - (propertize name 'face 'signel-contact)) - -(defun signel--timestamp (&rest p) - (propertize (apply #'concat p) 'face 'signel-timestamp)) - -(defun signel--notice (notice) - (propertize notice 'face 'signel-notice)) - -(defun signel--insert-prompt () - (let ((inhibit-read-only t) - (p (point))) - (insert signel-prompt) - (set-text-properties p (- (point) 1) - '(face signel-prompt - read-only t front-sticky t rear-sticky t)))) - -(defun signel--delete-prompt () - (when (looking-at-p (regexp-quote signel-prompt)) - (let ((inhibit-read-only t)) - (delete-char (length signel-prompt))))) - -(defun signel--delete-last-prompt () - (goto-char (point-max)) - (when (re-search-backward (concat "^" (regexp-quote signel-prompt))) - (signel--delete-prompt))) - -#+end_src - -With that, we're finally ready to insert messages in our signel chat -buffers: - -#+begin_src emacs-lisp -(defcustom signel-report-deliveries nil - "Whether to show message delivery notices." - :group 'signel - :type 'boolean) - -(defcustom signel-report-read t - "Whether to show message read notices." - :group 'signel - :type 'boolean) - -(defun signel--prompt-and-notify () - (signel--insert-prompt) - (when (fboundp 'tracking-add-buffer) - (tracking-add-buffer (current-buffer) '(signel-notification)))) - -(defun signel--needs-insert-p (data stamp rec-stamp msg) - (or data - (and (or rec-stamp stamp) - (not (string= source signel-cli-user)) - (or signel-report-deliveries - (and signel-report-read (signel--msg-is-read msg)))))) - -(defun signel--update-chat-buffer (source data stamp rec-stamp msg) - (when (signel--needs-insert-p data stamp rec-stamp msg) - (when-let ((b (signel--contact-buffer source))) - (with-current-buffer b - (signel--delete-last-prompt) - (if data - (let ((p (point))) - (insert (signel--timestamp "[" stamp "] ") - (signel--contact (signel--contact-name source)) - signel-prompt - data - "\n") - (fill-region p (point))) - (let ((is-read (signel--msg-is-read msg))) - (insert (signel--timestamp "*" (or rec-stamp stamp) "* ") - (signel--notice (if is-read "(read)" "(delivered)")) - "\n"))) - (signel--prompt-and-notify) - (end-of-line))))) -#+end_src - -There are some rough edges in the above implementation that must be -polished should signel ever be released in the wild. For one, proper -handling of timestamps and their formats. And of course notifications -should be much more customizable (here i'm using [[https://github.com/jorgenschaefer/circe/blob/master/tracking.el][Circe's tracking.el]] -if available). - -* Sending messages: the DBUS interface - -With that, we're going to receive and display messages and simple -receipts, and i'm sure that we will feel the urge to answer some of -them. As mentioned above, signal-cli let's us send messages via its -[[https://github.com/AsamK/signal-cli/wiki/DBus-service][DBUS interface]]. -In a nutshell, if you want to send ~MESSAGETEXT~ to a -~RECIPIENT~ you'd invoke something like: - -#+begin_src shell :tangle no -dbus-send --session --type=method_call \ - --dest="org.asamk.Signal" \ - /org/asamk/Signal \ - org.asamk.Signal.sendMessage \ - string:MESSAGETEXT array:string: string:RECIPIENT -#+end_src - -That is, call the method ~sendMessage~ of the corresponding service -interface with three arguments (the second one empty). Using emacs' -dbus libray one can write the above as: - -#+begin_src emacs-lisp -(defun signel--send-message (user msg) - (dbus-call-method :session "org.asamk.Signal" "/org/asamk/Signal" - "org.asamk.Signal" "sendMessage" - :string msg - '(:array) - :string user)) -#+end_src - -The only complicated bit is being careful with the specification of -the types of the method arguments: if one gets them wrong, DBUS will -simply complain and say that the method is not defined, which was -confusing me at first (but of course makes sense because DBUS allows -overloading method names, so the full method spec must include its -signature). - -We want to read whatever our user writes after the last prompt and -send it via the little helper above. Here's our interactive command -for that: - -#+begin_src emacs-lisp -(defun signel-send () - "Read text inserted in the current buffer after the last prompt and send it. - -The recipient of the message is looked up in a local variable set -when the buffer was created." - (interactive) - (goto-char (point-max)) - (beginning-of-line) - (let* ((p (point)) - (plen (length signel-prompt)) - (msg (buffer-substring (+ p plen) (point-max)))) - (signel--delete-prompt) - (signel--send-message signel-user msg) - (insert (signel--timestamp (format-time-string "(%H:%M) "))) - (fill-region p (point-max)) - (goto-char (point-max)) - (set-text-properties p (point) '(face signel-user)) - (insert "\n") - (signel--insert-prompt))) -#+end_src - -and we can bind it to the return key in signal chat buffers: - -#+begin_src emacs-lisp -(define-key signel-chat-mode-map "\C-m" #'signel-send) -#+end_src - -And we are going sometimes to want to talk to contacts that don't have -yet said anything and have, therefore, no associated chat buffer: - -#+begin_src emacs-lisp -(defun signel-query (contact) - "Start a conversation with a signal contact." - (interactive (list (completing-read "Signal to: " - (mapcar #'cdr-safe signel-contact-names)))) - (let ((phone (alist-get contact - (cl-pairlis (mapcar #'cdr signel-contact-names) - (mapcar #'car signel-contact-names)) - nil nil #'string-equal))) - (when (not phone) - (error "Unknown contact %s" contact)) - (pop-to-buffer (signel--contact-buffer phone)))) -#+end_src - -There are of course lots of rough edges and missing functionality in -this incipient signel, but it's already usable and a nice -demonstration of how easy it is to get the ball rolling in this lisp -machine of ours! diff --git a/lib/prog/jao-clojure.el b/lib/prog/jao-clojure.el new file mode 100644 index 0000000..7de62ba --- /dev/null +++ b/lib/prog/jao-clojure.el @@ -0,0 +1,192 @@ +;;; jao-clojure.el --- Clojure utilities -*- lexical-binding: t; -*- + +;; Copyright (C) 2025, 2026 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <mail@jao.io> +;; Keywords: languages + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Helpers for clojure coding + +;;; Code: + +(require 'clojure-mode) +(require 'project) +(require 'cider-test) +(require 'jao-skel) +(require 'jao-compilation) + +;;;; Jumping between implementation and test files +(defun jao-clojure--ext-dir (prefix) + (let* ((ext (file-name-extension buffer-file-name)) + (ext-rx (format "/%s/" ext))) + (if (string-match-p ext-rx buffer-file-name) + (format "%s/%s" prefix ext) + prefix))) + +(defun jao-clojure-find-current-test () + (save-excursion + (and (re-search-backward + "(deftest\\(?:\\W+^:\\w+\\)*\\W+\\b\\(.+\\)\\b" nil t) + (match-string-no-properties 1)))) + +(defvar jao-clojure--src-candidates '("lib" "src" "srv" "app")) + +(defun jao-clojure--test-namespace-p (ns) + (or (string-suffix-p "-test" ns) + (string-match "\\(.+\\)\\.\\(test\\)\\(\\..+\\)" ns))) + +(defun jao-clojure-test-buffer-p () + (jao-clojure--test-namespace-p (clojure-find-ns))) + +(defun jao-clojure--test-for (namespace sep) + (replace-regexp-in-string "\\." sep + (cider-test-default-test-ns-fn namespace))) + +(defun jao-clojure--infer-test-ns (ns) + (if (jao-clojure--test-namespace-p ns) + ns + (jao-clojure--test-for ns "."))) + +(defun jao-clojure--root () (project-root (project-current))) + +(defun jao-clojure--to-fname (x) + (replace-regexp-in-string "-" "_" x)) + +(defun jao-clojure-jump-to-test () + "Jump from implementation to test file." + (interactive) + (let* ((tn (jao-clojure--test-for (clojure-find-ns) "/")) + (bn (file-name-extension buffer-file-name)) + (f (format "%s%s/%s.%s" + (jao-clojure--root) + "test" + (jao-clojure--to-fname tn) + (jao-clojure--to-fname bn)))) + (find-file f))) + +(defun jao-clojure--implementation-for (namespace) + (thread-last (replace-regexp-in-string "-test$" "" namespace) + (replace-regexp-in-string "\\.test\\." ".") + (replace-regexp-in-string "-" "_") + (replace-regexp-in-string "\\." "/") + (substring-no-properties))) + +(defun jao-clojure--find-implementation (src) + (let ((f (format "%s%s/%s.%s" + (jao-clojure--root) + src + (jao-clojure--implementation-for (clojure-find-ns)) + (file-name-extension buffer-file-name)))) + (and (file-exists-p f) f))) + +(defun jao-clojure-jump-to-implementation () + "Jump from test file to implementation." + (interactive) + (let ((impl (car (seq-keep #'jao-clojure--find-implementation + jao-clojure--src-candidates)))) + (if impl (find-file impl) (message "No implementation file found")))) + +(defun jao-clojure-other-file () + "Toggle between implementation and test file" + (interactive) + (if (jao-clojure-test-buffer-p) + (jao-clojure-jump-to-implementation) + (jao-clojure-jump-to-test))) + +(defun jao-clojure--setup-compilation (&optional _ns) + ;; (set (make-local-variable 'compile-command) (jao-clojure--test-str ns)) + ) + +;;;; Skeletons +(defconst jao-clojure--ns-destruct-rx + (format "\\(?:%s\\|tests?\\)\\.\\(?:clj[cs]?\\.\\)?\\(.+\\)" + (regexp-opt jao-clojure--src-candidates))) + +(defun jao-clojure-buffer-namespace () + (let* ((ddir (jao-compilation-root)) + (mbase (and ddir + (concat (replace-regexp-in-string "/" "." ddir) "."))) + (mbase (and mbase + (string-match jao-clojure--ns-destruct-rx mbase) + (match-string 1 mbase)))) + (concat (or mbase "") + (replace-regexp-in-string "_" "-" (jao-skel-basename))))) + +(defvar jao-clojure--test-check-lines + (concat "[clojure.test.check :as tc]\n " + "[clojure.test.check.generators :as gen]\n " + "[clojure.test.check.properties :as prop :include-macros true]\n")) + +(defun jao-clojure--cljs-test-reqs (prefix-cmp last-cmp _test-check) + (concat " (:require [cljs.test :as t :refer-macros [is deftest async]]" + "\n [" prefix-cmp "." last-cmp " :as " last-cmp "])")) + +(defun jao-clojure--clj-test-reqs (prefix-cmp last-cmp test-check) + (format "(:use clojure.test)\n (:require %s(%s [%s :as %s]))" + (if test-check + (concat "(clojure.test.check [clojure-test :refer [defspec]])\n" + jao-clojure--test-check-lines) + "") + prefix-cmp last-cmp last-cmp)) + +(defun jao-clojure--cljc-test-reqs (prefix-cmp last-cmp test-check) + (concat "(:require #?(:clj [clojure.test :as t :refer [is deftest]]\n" + " :cljs [cljs.test :as t :refer-macros [is deftest]])\n" + (when test-check + (concat " [clojure.test.check-clojure-test #?@(" + ":cljs [:refer-macros [defspec]]\n" + ":clj [:refer [defspec]))]\n" + jao-clojure--test-check-lines)) + " [" prefix-cmp "." last-cmp " :as " last-cmp "])")) + +(defun jao-clojure--skel-ns-contents (ns) + (if (jao-clojure--test-namespace-p ns) + (let ((test-check (y-or-n-p "Include test.check requires? ")) + (ns (concat (match-string 1 ns) (match-string 3 ns)))) + (let* ((cmps (split-string ns "\\.")) + (last-cmp (car (last cmps))) + (prefix-cmp (mapconcat 'identity (butlast cmps) ".")) + (ext (file-name-extension buffer-file-name))) + (cond ((string= "cljs" ext) + (jao-clojure--cljs-test-reqs prefix-cmp last-cmp test-check)) + ((string= "cljc" ext) + (jao-clojure--cljc-test-reqs prefix-cmp last-cmp test-check)) + ((string= "clj" ext) + (jao-clojure--clj-test-reqs prefix-cmp last-cmp test-check))))) + (format "%S" (read-string "Brief module description: ")))) + +(define-skeleton jao-clojure-skeleton + "Standard Clojure module file skeleton" + "" + (jao-skel-copyright-line ";; ") + \n + (jao-skel-author-line ";; Author: ") + (jao-skel-date-line ";; Start date: ") + \n '(setq v1 (jao-clojure-buffer-namespace)) + _ "(ns " v1 + '(jao-clojure--setup-compilation v1) + \n (jao-clojure--skel-ns-contents v1) ")" + \n + '(ignore-errors (indent-region (region-beginning) (region-end))) + > -) + +(jao-skel-install "\\.clj[sc]?$" 'jao-clojure-skeleton) + + +(provide 'jao-clojure) +;;; jao-clojure.el ends here diff --git a/lib/prog/jao-compilation.el b/lib/prog/jao-compilation.el index c099701..42332cd 100644 --- a/lib/prog/jao-compilation.el +++ b/lib/prog/jao-compilation.el @@ -1,6 +1,6 @@ ;;; jao-compilation.el --- utilities to lauch compilations -*- lexical-binding: t; -*- -;; Copyright (C) 2020, 2021, 2022 jao +;; Copyright (C) 2020, 2021, 2022, 2025, 2026 jao ;; Author: jao <mail@jao.io> ;; Keywords: convenience @@ -33,7 +33,7 @@ (let (result) (dolist (v jao-compilation-environment result) (let ((vv (getenv v))) - (when vv (add-to-list 'result (format "%s=%s" v vv))))))) + (when vv (push (format "%s=%s" v vv) result)))))) ;;;###autoload (defun jao-compilation-add-dominating (&rest fs) @@ -67,8 +67,8 @@ ;;;###autoload (defun jao-compilation-root (&optional dir) - (when-let ((rfn (jao-compilation-find-root (or dir (buffer-file-name)) - jao-compilation-dominating-rx))) + (when-let* ((rfn (jao-compilation-find-root (or dir (buffer-file-name)) + jao-compilation-dominating-rx))) (let* ((default-directory (expand-file-name rfn)) (dir (file-name-directory rfn)) (rel-path (jao-path-relative-to dir default-directory))) @@ -80,13 +80,13 @@ ;;;###autoload (defun jao-compilation-root-file () - (when-let ((dir (jao-compilation-root))) + (when-let* ((dir (jao-compilation-root))) (car (directory-files dir nil jao-compilation-dominating-rx)))) ;;;###autoload (defun jao-find-compilation-root (dir) (when (and (stringp dir) (file-exists-p dir)) - (when-let ((root (jao-compilation-root dir))) + (when-let* ((root (jao-compilation-root dir))) (cons 'transient root)))) ;;;###autoload @@ -108,8 +108,8 @@ ;;;###autoload (defun jao-compilation-setup () (jao-compilation-add-dominating - "Makefile" "makefile" "configure.ac" "bootstrap.sh" "aclocal.m4" - "project.clj" "build.xml" "pom.xml" "setup.py" "stack.yaml") + "Makefile" "makefile" "configure.ac" "Cargo.toml" + "deps.edn" "project.clj" "build.xml" "pom.xml" "setup.py" "stack.yaml") (with-eval-after-load "project" (add-to-list 'project-find-functions #'jao-find-compilation-root t))) diff --git a/lib/prog/jao-rust.el b/lib/prog/jao-rust.el new file mode 100644 index 0000000..53b0058 --- /dev/null +++ b/lib/prog/jao-rust.el @@ -0,0 +1,142 @@ +;;; jao-rust.el --- Utilities for rust programming -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Jose Ruiz + +;; Author: Jose Ruiz <mail@jao.io> +;; Keywords: languages + +;; 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 <https://www.gnu.org/licenses/>. + +;;; Code: + +(declare-function rustic-cargo-bin "rustic") +(declare-function rustic-run-cargo-command "rustic") +(defvar rustic-cargo-test-runner) +(defvar rustic-cargo-use-last-stored-arguments) +(defvar rustic-default-test-arguments) +(defvar rustic-test-arguments) + +(defun jao-rust--root () + (locate-dominating-file default-directory "Cargo.toml")) + +(defun jao-rust-open-cargo () + (interactive) + (let ((f (expand-file-name "Cargo.toml" (jao-rust--root)))) + (when (or (file-exists-p f) + (y-or-n-p "No Cargo.toml found. Create? ")) + (find-file f)))) + +(defun jao-rust-current-module-name () + (let* ((root (expand-file-name (jao-rust--root))) + (current (file-name-sans-extension (buffer-file-name))) + (rel (string-replace root "" current))) + (and (string-prefix-p "src/" rel) + (thread-last + rel + (replace-regexp-in-string "^src\\(/bin\\)?/" "") + (string-replace "-" "_") + (replace-regexp-in-string "\\(^\\|/\\)\\(mod\\|lib\\|main\\)$" "") + (string-replace "/" "::"))))) + +(defun jao-rust--tests-prefix () + (let ((m (jao-rust-current-module-name))) + (cond ((not (stringp m)) "") + ((string-empty-p m) "tests::") + (t (concat m "::tests::"))))) + +(defconst jao-rust--test-header-rx + (concat "#\\[" (regexp-opt '("test" "quickcheck" "tokio::test") t))) + +(defconst jao-rust--test-name-rx "^ *\\(pub \\)?\\( async \\)?fn \\([^(]+\\)(") + +(defun jao-rust-test-at-point () + (when (looking-at jao-rust--test-name-rx) (match-string-no-properties 3))) + +(defun jao-rust-test-before-point () + (save-excursion + (when (re-search-backward jao-rust--test-header-rx nil t) + (forward-line) + (jao-rust-test-at-point)))) + + +(defconst jao-rust--tests-mod-rx "^\\(pub\\)? *mod tests {") + +(defun jao-rust-goto-tests () + (interactive) + (or (re-search-forward jao-rust--tests-mod-rx nil t) + (re-search-backward jao-rust--tests-mod-rx nil t) + (progn + (goto-char (point-min)) + (re-search-forward jao-rust--test-header-rx nil t)) + (when (y-or-n-p "No tests module. Add it?") + (goto-char (point-max)) + (insert "\n#[cfg(test)]\nmod tests {\n\n}") + (forward-line -1)))) + +(defun jao-rust-test-current () + (interactive) + (if-let* ((m (jao-rust--tests-prefix)) + (n (jao-rust-test-before-point))) + (let ((rustic-test-arguments (format "-- --exact %s%s" m n)) + (rustic-cargo-use-last-stored-arguments t)) + (rustic-cargo-test)) + (message "No test before point"))) + +(defun jao-rust-buffer-tests () + (save-excursion + (goto-char (point-min)) + (let ((res '())) + (while (re-search-forward jao-rust--test-header-rx nil t) + (forward-line) + (when-let* ((name (jao-rust-test-at-point))) (push name res))) + res))) + +(defun jao-rust-test-module () + (interactive) + (let ((tests (jao-rust-buffer-tests))) + (if (seq-empty-p tests) + (when (y-or-n-p "No tests in this module. Run doc tests?") + (jao-rust-test-doctests)) + (let* ((prefix (jao-rust--tests-prefix)) + (tests (mapconcat (lambda (x) (format "%s%s" prefix x)) tests " ")) + (rustic-test-arguments (format "-- --exact %s" tests)) + (rustic-cargo-use-last-stored-arguments t)) + (rustic-cargo-test))))) + +(defun jao-rust-test-doctests (&optional all) + (interactive "P") + (let* ((m (if all "" (jao-rust-current-module-name))) + (rustic-cargo-test-runner 'cargo) + (rustic-test-arguments (format "--doc %s" m)) + (rustic-cargo-use-last-stored-arguments t)) + (rustic-cargo-test))) + +(defun jao-rust-retest () + (interactive) + (let* ((rustic-test-arguments "-R latest") + (rustic-cargo-use-last-stored-arguments t)) + (rustic-cargo-test))) + +(defun jao-rust-test-workspace () + (interactive) + (let ((rustic-test-arguments rustic-default-test-arguments)) + (rustic-cargo-test))) + + +(defun jao-rust-build-doc (deps) + (interactive "P") + (rustic-run-cargo-command `(,(rustic-cargo-bin) "doc" ,@(unless deps '("--no-deps"))))) + +(provide 'jao-rust) +;;; jao-rust.el ends here diff --git a/lib/prog/jao-sloc.el b/lib/prog/jao-sloc.el index 1f0e9ab..a325871 100644 --- a/lib/prog/jao-sloc.el +++ b/lib/prog/jao-sloc.el @@ -1,4 +1,4 @@ -;; sloc.el -- LOC utilities +;; sloc.el -- LOC utilities -*- lexical-binding: t; -*- ;;;###autoload (defun count-sloc-region (beg end kind) diff --git a/lib/prog/jao-vterm-repl.el b/lib/prog/jao-vterm-repl.el deleted file mode 100644 index 699ff39..0000000 --- a/lib/prog/jao-vterm-repl.el +++ /dev/null @@ -1,130 +0,0 @@ -;;; jao-vterm-repl.el --- vterm-based repls -*- lexical-binding: t; -*- - -;; Copyright (C) 2020, 2021 jao - -;; Author: jao <mail@jao.io> -;; Keywords: terminals - -;; 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 <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Helpers to launch reply things such as erlang shells inside a vterm. -;; For instance, to declare an erl repl for rebar projects, one would call: -;; -;; (jao-vterm-repl-register "rebar.config" "rebar3 shell" "^[0-9]+> ") - -;;; Code: - -(require 'jao-compilation) - -(declare-function 'vterm-copy-mode "vterm") -(declare-function 'vterm-send-string "vterm") -(declare-function 'vterm-send-return "vterm") - -(defun jao-vterm-repl--buffer-name (&optional dir) - (format "*vterm -- repl - %s*" (or dir (jao-compilation-root)))) - -(defvar jao-vterm-repl-repls nil) -(defvar jao-vterm-repl-prompts nil) -(defvar-local jao-vterm-repl--name nil) -(defvar-local jao-vterm-repl--last-buffer nil) -(defvar-local jao-vterm-repl--prompt-rx "^[0-9]+> ") - -(setq vterm-buffer-name-string nil) - -(defun jao-vterm-repl--exec (cmd &optional name) - (vterm name) - (when name - (vterm-send-string "unset PROMPT_COMMAND\n\n")) - (vterm-send-string cmd) - (vterm-send-return) - (when name (rename-buffer name t))) - -;;;###autoload -(defun jao-vterm-repl-previous-prompt () - (interactive) - (when (derived-mode-p 'vterm-mode) - (vterm-copy-mode 1) - (forward-line 0) - (when (re-search-backward jao-vterm-repl--prompt-rx nil t) - (goto-char (match-end 0))))) - -;;;###autoload -(defun jao-vterm-repl-next-prompt () - (interactive) - (when (derived-mode-p 'vterm-mode) - (vterm-copy-mode 1) - (or (re-search-forward jao-vterm-repl--prompt-rx nil t) - (vterm-copy-mode -1)) - (unless (save-excursion - (re-search-forward jao-vterm-repl--prompt-rx nil t)) - (vterm-copy-mode -1)))) - -;;;###autoload -(define-minor-mode jao-vterm-repl-mode "repl-aware vterm" nil nil - '(("\C-c\C-p" . jao-vterm-repl-previous-prompt) - ("\C-c\C-n" . jao-vterm-repl-next-prompt) - ("\C-c\C-z" . jao-vterm-repl-pop-to-src))) - -;;;###autoload -(defun jao-vterm-repl () - (let* ((dir (jao-compilation-root)) - (vname (jao-vterm-repl--buffer-name dir)) - (root-name (jao-compilation-root-file)) - (buffer (seq-find `(lambda (b) - (string= - (buffer-local-value 'jao-vterm-repl--name - b) - ,vname)) - (buffer-list)))) - (or buffer - (let ((default-directory dir) - (prompt (cdr (assoc root-name jao-vterm-repl-prompts))) - (cmd (or (cdr (assoc root-name jao-vterm-repl-repls)) - (read-string "REPL command: "))) - (bname (format "* vrepl - %s/%s *" - (file-name-base (string-remove-suffix "/" dir)) - root-name))) - (jao-vterm-repl--exec cmd bname) - (jao-vterm-repl-mode) - (setq-local jao-vterm-repl--name vname) - (when prompt (setq-local jao-vterm-repl--prompt-rx prompt)) - (current-buffer))))) - -;;;###autoload -(defun jao-vterm-repl-register (build-file repl-cmd prompt-rx) - (jao-compilation-add-dominating build-file) - (add-to-list 'jao-vterm-repl-repls (cons build-file repl-cmd)) - (add-to-list 'jao-vterm-repl-prompts (cons build-file prompt-rx))) - -;;;###autoload -(defun jao-vterm-repl-pop-to-repl () - (interactive) - (let ((bn (current-buffer))) - (pop-to-buffer (jao-vterm-repl)) - (setq-local jao-vterm-repl--last-buffer bn))) - -;;;###autoload -(defun jao-vterm-repl-pop-to-src () - (interactive) - (when (buffer-live-p jao-vterm-repl--last-buffer) - (pop-to-buffer jao-vterm-repl--last-buffer))) - -;;;###autoload -(defun jao-vterm-repl-send (cmd) - (with-current-buffer (jao-vterm-repl) (vterm-send-string cmd))) - -(provide 'jao-vterm-repl) -;;; jao-vterm-repl.el ends here diff --git a/lib/readme.org b/lib/readme.org index ca494f4..60b1942 100644 --- a/lib/readme.org +++ b/lib/readme.org @@ -5,5 +5,4 @@ - [[./media][media]] utilities for music players and the like - [[./prog][prog]] utilities for compilation and programming modes - [[./net][net]] utilities for networking (w3m, weather &c.) - - [[./themes][themes]] color themes based on Emacs builtin custom themes - [[./skels][skels]] a collection of emacs skeletons diff --git a/lib/skels/jao-skel-cpp.el b/lib/skels/jao-skel-cpp.el index 0ddb61e..1180495 100644 --- a/lib/skels/jao-skel-cpp.el +++ b/lib/skels/jao-skel-cpp.el @@ -1,6 +1,6 @@ ;;; jao-skel-cpp.el -*- lexical-binding: t; -*- -;; Copyright (C) 2004, 2005, 2008, 2009, 2022 Jose Antonio Ortega Ruiz +;; Copyright (C) 2004, 2005, 2008, 2009, 2022, 2026 Jose Antonio Ortega Ruiz ;; Author: Jose A Ortega Ruiz <jao@gnu.org> ;; Keywords: tools @@ -50,7 +50,7 @@ ;;; Auxiliar functions (defun jao-skel-cpp--find-other (ext) (file-name-nondirectory - (or (ff-other-file-name) + (or (ff-get-other-file) (concat (file-name-sans-extension (buffer-name)) "." ext)))) (defun jao-skel-cpp-make-guard-name (ns) @@ -68,7 +68,7 @@ (defsubst jao-skel-cpp--ns2str (ns) (mapconcat 'identity ns "::")) (defun jao-skel-cpp--get-ns-list (&optional acc) - (do* ((result acc (cons next result)) + (cl-do* ((result acc (cons next result)) (next (jao-skel-cpp--read-ns (jao-skel-cpp--ns2str acc)) (jao-skel-cpp--read-ns (jao-skel-cpp--ns2str (reverse result))))) ((string= next "") (reverse result)))) @@ -98,11 +98,11 @@ (while (re-search-forward "namespace\\s-\\w+\\s-{\\|}+\\s-//\\s-namespace" nil t) (push (thing-at-point 'line) lines) - (next-line))) + (forward-line))) lines)) (defun jao-skel-cpp--copy-namespace () - (let* ((name (ff-other-file-name)) + (let* ((name (ff-get-file-name)) (buff (and name (find-file-noselect name))) (nlines)) (when buff diff --git a/lib/skels/jao-skel-haskell.el b/lib/skels/jao-skel-haskell.el index 01a9936..0c3c17d 100644 --- a/lib/skels/jao-skel-haskell.el +++ b/lib/skels/jao-skel-haskell.el @@ -1,4 +1,5 @@ -;;; jao-skel-haskell.el --- skeleton for haskell source files -*- lexical-binding: t; -*- +;; jao-skel-haskell.el --- skeleton for haskell -*- lexical-binding: t; -*- + ;; Copyright (C) 2003, 2004, 2005, 2009, 2010, 2012, 2022 Jose A Ortega Ruiz ;; Author: Jose A Ortega Ruiz <jao@member.fsf.org> @@ -19,31 +20,23 @@ ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. -;;; Commentary: - -;; - ;;; Code: (require 'jao-skel) (require 'jao-compilation) +(require 'haskell-mode nil t) -;;; Auxiliar -(defun jao-skel--read-haskell-module () - (let* ((ddir (jao-compilation-root)) - (mbase (and ddir (concat (replace-regexp-in-string "/" "." ddir) - "."))) - (m (read-string "Module prefix (empty for no module): " - (concat (or mbase "") (jao-skel-basename))))) - (or m ""))) +(defun jao-skel-haskell--guess-module () + (if (fboundp 'haskell-guess-module-name) + (haskell-guess-module-name) + (read-string "Module: " (jao-skel-basename)))) (defconst jao-skel--haskell-line (make-string 78 ?-)) -;;; Skeletons (define-skeleton jao-skel-haskell-file "Haskell hs file header" "Brief description: " - '(setq v (jao-skel--read-haskell-module)) + '(setq v (jao-skel-haskell--guess-module)) jao-skel--haskell-line \n "-- |" \n "-- Module: " v \n @@ -63,7 +56,6 @@ "module " v " where " \n \n \n) (jao-skel-install "\\.hs\\'" 'jao-skel-haskell-file) -;; (jao-skel-install "\\.lhs\\'" 'jao-skel-lit-haskell-file) (provide 'jao-skel-haskell) diff --git a/lib/themes/jao-dark-theme.el b/lib/themes/jao-dark-theme.el deleted file mode 100644 index 9e07f1a..0000000 --- a/lib/themes/jao-dark-theme.el +++ /dev/null @@ -1,136 +0,0 @@ -;;; jao-dark-theme.el --- a dark theme with blue-green accent -*- lexical-binding: t; -*- - -;; Author: jao <mail@jao.io> -;; Keywords: themes - -;; 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 <https://www.gnu.org/licenses/>. - -(defvar jao-theme-dark-bold - (if (> emacs-major-version 28) 'medium 'semibold)) - -(jao-define-custom-theme jao-dark - (:names (bg "#282b33" nil nil) - (bg-alt "#1f2024" nil nil) - (fg "#c6c6c6") - (fg-0.5 "#a6a6a6") - (fg-1 "#868686") - (fg-2 "#666666") - (blue "#819cd6") - (blueish "#6e7899") - (dark-blue "#616c96") - (green "#5b94ab") - (yellow "antiquewhite3") - (dark-yellow "antiquewhite4") - (orange "#a6c1e0") - (orange2 "#dd8844") - (red "#e1c1ee" "#ff6655" "red") - (comments "azure4" "lightblue4") - (constants "honeydew4") - (dimm-line-fg "#3f3f3f") - (dimm-line "#7f7f7f") - (error "#e1c1ee") - (functions "#7ebebd") - (functions2 "#44b9b1") - (keywords "cadetblue3") - (keywords2 "#51afef") - (modeline-bg "#22242b") - (modeline-bg-inactive "#24262d") - ;;(region "#41454b") - (region "#31353b") - (strings "honeydew3") - (success "#5b94ab") - (warning "#cfcf9c") - (warning2 "#ECBE7B")) - (:face-family "Fira Code") - (:face-size 9) - (:bold-weight jao-theme-dark-bold) - (:palette (fg "#c6c6c6") - (bg "#1f2024") - (box "grey25") - (button (p f12) bx nul) - (hilite (c nil region) ex) - (link (ul dark-blue)) ;; (ul dimm-line) - (visited-link (ul dark-blue)) - (tab-sel (c 252 232) nbf) - (tab-unsel (c 245 232)) - (comment (c comments)) - (keyword (c keywords)) - (function (c functions)) - (type (c constants)) - (variable-name (c nil)) - (constant (c constants)) - (string (c strings) it) - (error (c warning2)) - (warning (c warning)) - (success (c green)) - (dimm (c dimm-line)) - (gnus-mail (c nil)) - (gnus-news (c nil)) - (outline-1 (c strings) nbf) - (outline-2 (c functions) nbf) - (outline-3 (c blue) nbf) - (outline-4 (c functions2) nbf) - (outline-5 (c nil)) - (f00 (c "lightskyblue3")) - (f01 (c "lightskyblue4")) - (f02 (c "lightblue3")) - (f10 (c "lightblue4")) - (f11 (c "lightblue2")) - (f12 (c "azure3"))) - (:x-faces (clojure-keyword-face (c "powder blue")) - (corfu-background (c "white" "grey20")) - (corfu-bar (c nil "grey20")) ;; moving part of the bar - (corfu-border (~ corfu-background)) ;; background of the bar - (corfu-current (c "white" "grey50") nbf nit nul) - (corfu-echo (~ default)) - (cursor (c warning2 warning2)) - (diff-hl-change (c green)) - (diff-hl-delete (c orange2) bf) - (diff-hl-insert (c dark-blue)) - (fill-column-indicator (c "black") :inherit nil) - (font-lock-doc-face (~ font-lock-comment-face) it) - (fringe (p dimm)) - (gnus-button (c "lightyellow3")) - (gnus-cite-1 (c fg-0.5)) - (gnus-cite-2 (c fg-1)) - (gnus-cite-3 (c fg-2)) - (gnus-cite-4 (c fg-2)) - ;; (gnus-group-mail-3 (c yellow)) - ;; (gnus-group-mail-3-empty (c fg-0.5)) - ;; (gnus-group-news-3 (~ gnus-group-mail-3)) - ;; (gnus-group-news-3-empty (~ gnus-group-mail-3-empty)) - ;; (gnus-group-mail-low (p f10)) - ;; (gnus-group-mail-low-empty (~ gnus-group-mail-3-empty)) - (gnus-summary-cancelled (c "dark slate gray" nil) st) - (gnus-summary-selected (p warning) nul nbf) - (header-line (p hilite)) - (magit-diff-context-highlight (p hilite) ex) - (mode-line (c "grey60" modeline-bg) - :box (:line-width 1 :color "#282b33")) - (mode-line-inactive (c "grey35" modeline-bg-inactive) - :box (:line-width 1 :color "#282b33")) - (mode-line-buffer-id (c yellow)) - (org-hide (c 0 nil)) - (org-code (c yellow)) - (scroll-bar (c bg)) - (show-paren-match (c "darkseagreen1" "#5f5f5f")) - (shr-link (c blue) (ul dark-blue)) - (vertical-border (c "black") :inherit nil) - (vertico-group-separator (p dimm) :strike-through "#6f6f6f"))) - -;; (enable-theme 'jao-dark) -;; (jao-mode-line-adjust-faces) - - -(provide 'jao-dark-theme) diff --git a/lib/themes/jao-light-theme.el b/lib/themes/jao-light-theme.el deleted file mode 100644 index bd3fcdf..0000000 --- a/lib/themes/jao-light-theme.el +++ /dev/null @@ -1,121 +0,0 @@ -;;; jao-light-theme.el --- a light theme -*- lexical-binding: t; -*- - -;; Author: jao <mail@jao.io> -;; Keywords: themes - -;; 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 <https://www.gnu.org/licenses/>. - -(defvar jao-theme-light-bold (if (> emacs-major-version 28) 'medium 'semibold)) - -(jao-define-custom-theme jao-light - (:names (bg-lightest "gray98") - (bg-light "gray95") - - (light-gray "gray80") - - (black "black") - (dark-gray "gray30") - (fg-light "gray40") - - (hl "#f2f2f2") - (dimm "lemonchiffon4") - - (search "#e8e800") - (search2 "#ffffb4") - - (warning "orange4") - (red "burlywood4") - (blue "#023770") - (green "#005555")) - (:face-size 9) - (:face-family "Fira Code") - (:bold-weight jao-theme-light-bold) - (:palette (fg "black") - (bg "white") - (box "gray80") - (button (c fg-light bg-lightest) (ul light-gray)) - (hilite (c nil hl)) - (link (c green) nbf (ul light-gray)) - (visited-link (ul light-gray) nbf) - (tab-sel (~ mode-line)) - (tab-unsel (~ mode-line-inactive)) - (comment (c fg-light) it) - (keyword (c blue) bf) - (type (c blue) nbf) - (function (c green)) - (variable-name (c black)) - (constant (c dark-gray)) - (string (c blue) nit) - (warning (c warning)) - (error (c red) bf) - (dimm (c dimm)) - (gnus-mail (c "black")) - (gnus-news (c "black")) - (outline (c "black") bf) - (outline-1 (c green) bf) - (outline-2 (c green) nbf) - (outline-3 (c blue) nul nbf) - (outline-4 (c blue) nul nbf) - (outline-5 (c blue) nul nbf) - (f00 (c green)) - (f01 (c blue)) - (f02 (c dark-gray)) - (f10 (p f00)) - (f11 (p f01)) - (f12 (p f02))) - (:x-faces (compilation-info (c "#223142" nil) nbf) - (completions-group-separator (c nil ni) (st "grey80")) - (corfu-default (~ default) (c "black" "grey95")) - (corfu-bar (c nil "grey80")) ;; moving part of the bar - (corfu-border (~ corfu-background)) ;; background of the bar - (corfu-current (c "black" "grey95") nbf nit (ul "grey70")) - (cursor (c "sienna3" "sienna3")) - (diff-hl-change (c "white" pale-blue)) - (diff-hl-insert (c "white" "honeydew2")) - (diff-hl-delete (c "white" "wheat1")) - (fill-column-indicator (c "grey80")) - (fringe (c "grey70" nil)) - (gnus-button (c blue)) - (gnus-cite-1 (c "darkslategray" nil)) - (gnus-cite-2 (c "slate gray" nil)) - (gnus-cite-3 (c "slate gray" nil)) - (gnus-cite-4 (c "slate gray" nil)) - (gnus-header-name (c fg-light)) - (gnus-summary-selected (c green) nbf) - (gnus-summary-cancelled (c "sienna3" nil) st) - (header-line (c dark-gray bg-lightest) - :box (:line-width 1 :color "grey90")) - (magit-diff-context-highlight (c nil hl) ex) - (magit-diff-hunk-heading-highlight (c nil hl) it bf) - (mode-line (c "grey30" bg-light) - :box (:line-width -1 :color "grey90")) - (mode-line-inactive (c "grey40" "white") - :box (:line-width -1 :color "grey90")) - (mode-line-buffer-id (~ default) (c dark-blue-2 nil) nit) - (mode-line-emphasis (c green nil)) - (mode-line-highlight (c green nil)) - (org-link (p link) (ul "grey80")) - (scroll-bar (c "grey80" nil)) - (show-paren-match (c nil "grey85")) - (shr-text (c nil nil)) - (shr-link (~ link) (ul light-gray)) - (shr-code (c blue nil)) - (success (c green)) - (vertical-border (c "grey70" nil)) - (widget-button (~ default) nit (ul "grey80")))) - -;; (enable-theme 'jao-light) -;; (jao-mode-line-adjust-faces) - -(provide 'jao-light-theme) |