jiri/org-ql
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add/Change/Fix: Storing links to containing buffer or files

Browse source 
This feels too complicated, but I don't see a way around it, short of
redesigning all of the argument expansion/contraction, which might end
up in the same place, anyway.

See #147.
This commit is contained in:
Adam Porter 2020-11-10 21:17:27 -06:00
parent 8102d7a8ee
commit bfd4d462a0
1 changed files with 54 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

93
org-ql-view.el
View file

@ -623,7 +623,7 @@ protocol. See, e.g. `org-ql-view--link-store'."
(title (--when-let (alist-get "title" params nil nil #'string=) (title (--when-let (alist-get "title" params nil nil #'string=)
(read it))) (read it)))
(buffers-files (--if-let (alist-get "buffers-files" params nil nil #'string=) (buffers-files (--if-let (alist-get "buffers-files" params nil nil #'string=)
(read it) (org-ql-view--expand-buffers-files (read it))
(current-buffer)))) (current-buffer))))
(when (and org-ql-view-ask-unsafe-links (when (and org-ql-view-ask-unsafe-links
(or (string-match (rx bol (0+ space) "(") query) (or (string-match (rx bol (0+ space) "(") query)
@ -642,39 +642,43 @@ protocol. See, e.g. `org-ql-view--link-store'."
:super-groups groups :super-groups groups
:title title))) :title title)))
(defvar org-ql-view--link-store-counter 0
"Workaround for an idiosyncrasy of `org-store-link' that calls link-storing functions twice.")
(defun org-ql-view--link-store () (defun org-ql-view--link-store ()
"Store a link to the current Org QL view. "Store a link to the current Org QL view.
When opened, the link searches the buffer it's opened from." When opened, the link searches the buffer it's opened from."
(require 'url-parse) (require 'url-parse)
(require 'url-util) (require 'url-util)
(when org-ql-view-query (when org-ql-view-query
(unless (cl-etypecase org-ql-view-buffers-files (cl-incf org-ql-view--link-store-counter)
;; I really wish `anaphora' were in ELPA, because `aetypecase' would be ;; Only Org QL View buffers should have `org-ql-view-query' set.
;; nice here, and I'd prefer to avoid adding more MELPA-only dependencies. (cl-flet ((prompt-for (buffers-files)
(buffer t) ;; HACK: Use counter to avoid prompting the first of the
(string (file-exists-p org-ql-view-buffers-files)) ;; two times that `org-store-link' calls this function.
(list (and (cl-every #'stringp org-ql-view-buffers-files) (when (cl-evenp org-ql-view--link-store-counter)
(cl-every #'file-exists-p org-ql-view-buffers-files)))) (pcase-exhaustive
(user-error "Can only store links to views of either a single buffer/file or a list of files")) (completing-read (format "Link to search file containing inserted link or %s? " buffers-files)
(let* ((params (list (when (and org-ql-view-buffers-files (list "containing file" buffers-files) nil t)
;; If it's one buffer (i.e. the view searches the current ("containing file" nil)
;; buffer), don't serialize it, because buffers are unreadable. (buffers-files (prin1-to-string buffers-files))))))
(not (bufferp org-ql-view-buffers-files))) (let* ((buffers-files (prompt-for (org-ql-view--contract-buffers-files org-ql-view-buffers-files)))
(list "buffers-files" (prin1-to-string org-ql-view-buffers-files))) (params (list (when buffers-files
(when org-ql-view-super-groups (list "buffers-files" buffers-files))
(list "super-groups" (prin1-to-string org-ql-view-super-groups))) (when org-ql-view-super-groups
(when org-ql-view-sort (list "super-groups" (prin1-to-string org-ql-view-super-groups)))
(list "sort" (prin1-to-string org-ql-view-sort))) (when org-ql-view-sort
(when org-ql-view-title (list "sort" (prin1-to-string org-ql-view-sort)))
(list "title" (prin1-to-string org-ql-view-title))))) (when org-ql-view-title
(filename (concat (url-hexify-string (org-ql-view--format-query org-ql-view-query)) (list "title" (prin1-to-string org-ql-view-title)))))
"?" (url-build-query-string (delete nil params)))) (filename (concat (url-hexify-string (org-ql-view--format-query org-ql-view-query))
(url (url-recreate-url (url-parse-make-urlobj "org-ql-search" nil nil nil nil "?" (url-build-query-string (delete nil params))))
filename)))) (url (url-recreate-url (url-parse-make-urlobj "org-ql-search" nil nil nil nil
(org-store-link-props filename))))
:type "org-ql-search" (org-store-link-props
:link url :type "org-ql-search"
:description (concat "org-ql-search: " org-ql-view-title))) :link url
:description (concat "org-ql-search: " org-ql-view-title))))
t)) t))
;;;; Transient ;;;; Transient
@ -992,6 +996,9 @@ property."
;;;;; Completion ;;;;; Completion
;; These functions are somewhat regrettable because of the need to keep them
;; in sync, but it seems worth it to provide users with the flexibility.
(defun org-ql-view--contract-buffers-files (buffers-files) (defun org-ql-view--contract-buffers-files (buffers-files)
"Return BUFFERS-FILES in its \"contracted\" form. "Return BUFFERS-FILES in its \"contracted\" form.
The contracted form is \"org-agenda-files\" if BUFFERS-FILES The contracted form is \"org-agenda-files\" if BUFFERS-FILES
@ -1020,6 +1027,8 @@ current buffer. Otherwise BUFFERS-FILES is returned unchanged."
"buffer") "buffer")
((or 'org-agenda-files '(function org-agenda-files)) ((or 'org-agenda-files '(function org-agenda-files))
"org-agenda-files") "org-agenda-files")
((and (pred bufferp) (guard (file-exists-p (buffer-file-name buffers-files))))
(buffer-file-name buffers-files))
(_ (let ((print-length nil)) (_ (let ((print-length nil))
(prin1-to-string buffers-files)))))) (prin1-to-string buffers-files))))))
@ -1034,17 +1043,23 @@ current buffer. Otherwise BUFFERS-FILES is returned unchanged."
;; Buffers can't be input by name, so if the default value is a buffer, just use it. ;; Buffers can't be input by name, so if the default value is a buffer, just use it.
;; TODO: Find a way to fix this. ;; TODO: Find a way to fix this.
org-ql-view-buffers-files org-ql-view-buffers-files
(pcase-exhaustive (org-ql-view--expand-buffers-files
(completing-read "Buffers/Files: " (completing-read "Buffers/Files: "
(list 'buffer 'org-agenda-files 'org-directory 'all) (list 'buffer 'org-agenda-files 'org-directory 'all)
nil nil (initial-input)) nil nil (initial-input))))))
((or "" "buffer") (current-buffer))
("org-agenda-files" (org-agenda-files)) (defun org-ql-view--expand-buffers-files (buffers-files)
("all" (--select (equal (buffer-local-value 'major-mode it) 'org-mode) "Return BUFFERS-FILES expanded to a list of files or buffers.
(buffer-list))) The counterpart to `org-ql-view--contract-buffers-files'."
("org-directory" (org-ql-search-directories-files)) (pcase-exhaustive buffers-files
((and form (guard (rx bos "("))) (-flatten (eval (read form)))) ((pred bufferp) buffers-files)
(else (s-split (rx (1+ space)) else)))))) ((or "" "buffer") (current-buffer))
("org-agenda-files" (org-agenda-files))
("all" (--select (equal (buffer-local-value 'major-mode it) 'org-mode)
(buffer-list)))
("org-directory" (org-ql-search-directories-files))
((and form (guard (rx bos "("))) (-flatten (eval (read form))))
(else (s-split (rx (1+ space)) else))))
(defun org-ql-view--complete-super-groups () (defun org-ql-view--complete-super-groups ()
"Return value for `org-ql-view-super-groups' using completion." "Return value for `org-ql-view-super-groups' using completion."