;;; org-ql-view.el --- Agenda-like view based on org-ql  -*- lexical-binding: t; -*-

;; Copyright (C) 2019-2023  Adam Porter

;; Author: Adam Porter <adam@alphapapa.net>
;; Url: https://github.com/alphapapa/org-ql

;;; Commentary:

;; This library is part of the package `org-ql'; it's not a standalone
;; library.  It displays strings in buffers similar to Org Agenda
;; buffers.

;;; License:

;; 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:

;;;; Requirements

(require 'cl-lib)
(require 'crm)
(require 'map)
(require 'org)
(require 'org-element)
(require 'org-agenda)
(require 'seq)
(require 'rx)
(require 'subr-x)

(require 'org-ql)

(declare-function org-ql-search "org-ql-search" t)
(declare-function org-ql-search--org-link-store-props "org-ql-search" t)
(declare-function org-ql--normalize-query "org-ql" t t)

(require 'dash)
(require 's)
(require 'org-super-agenda)
(require 'ov)
(require 'ts)

;;;; Faces

(defface org-ql-view-due-date
  '((t (:slant italic :weight bold)))
  "Face for due dates in `org-ql-view' views."
  :group 'org-ql-view)

(defface org-ql-view-query nil
  "View query in header line.
This face is added to the formatted query after font-lock faces
are applied to it.  It may be used, e.g. to reduce the height so
more of it is visible."
  :group 'org-ql-view)

(defface org-ql-view-title '((t :weight bold))
  "View title in header line."
  :group 'org-ql-view)

;;;; Variables

(defvar org-ql-view-buffer-name-prefix "*Org QL View:"
  "Prefix for names of `org-ql-view' buffers.")

(defvar org-ql-view-buffer nil
  "Optionally set the target buffer for `org-ql-view' commands.
Includes `org-ql-search'.  Helpful when passing a buffer argument
down a chain of function calls would be awkward.")

(defvar org-ql-view-map
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map org-agenda-mode-map)
    (define-key map "g" #'org-ql-view-refresh)
    (define-key map "r" #'org-ql-view-refresh)
    (define-key map "q" #'bury-buffer)
    (define-key map "v" #'org-ql-view-dispatch)
    (define-key map (kbd "C-x C-s") #'org-ql-view-save)
    map)
  "Keymap for `org-ql-view', `org-ql-search', and `org-ql-views' views.
Based on `org-agenda-mode-map'.")

(defvar org-ql-view-list-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "RET") #'org-ql-view-switch)
    (define-key map [mouse-1] #'org-ql-view-switch)
    (define-key map "c" #'org-ql-view-customize)
    map)
  "Keymap for `org-ql-view' view list buffer.")

;; For refreshing results buffers.
(defvar-local org-ql-view-buffers-files nil)
(defvar-local org-ql-view-query nil)
(defvar-local org-ql-view-sort nil)
(defvar-local org-ql-view-narrow nil)
(defvar-local org-ql-view-super-groups nil)
(defvar-local org-ql-view-title nil)

;;;; Customization

(defgroup org-ql-view nil
  "Options for `org-ql-view'."
  :group 'org-ql)

(defcustom org-ql-view-display-buffer-action nil
  "Action argument passed through `pop-to-buffer' to `display-buffer', which see."
  :type '(cons function alist))

(defcustom org-ql-view-list-side 'right
  "Which side to show the view list on."
  :type '(choice (const :tag "Left" left)
                 (const :tag "Right" right)))

(defcustom org-ql-view-no-other-window nil
  "Whether `other-window' commands should cycle through `org-ql-views' sidebar.
See info node `(elisp)Cyclic Window Ordering'."
  :type 'boolean)

(defcustom org-ql-view-list-slot 0
  "Side-window slot for Org QL Views list buffer."
  :type 'integer)

(defcustom org-ql-view-sidebar-sort-views nil
  "Sort `org-ql-views' in `org-ql-view-sidebar'."
  :type 'boolean)

(defcustom org-ql-views
  (list (cons "Overview: Agenda-like"
              (list :buffers-files #'org-agenda-files
                    :query '(and (not (done))
                                 (or (habit)
                                     (deadline auto)
                                     (scheduled :to today)
                                     (ts-active :on today)))
                    :sort '(todo priority date)
                    :super-groups 'org-super-agenda-groups
                    :title "Agenda-like"))
        (cons "Overview: NEXT tasks"
              (list :buffers-files #'org-agenda-files
                    :query '(todo "NEXT")
                    :sort '(date priority)
                    :super-groups 'org-super-agenda-groups
                    :title "Overview: NEXT tasks"))
        (cons "Calendar: Today"
              (list :buffers-files #'org-agenda-files
                    :query '(ts-active :on today)
                    :title "Today"
                    :super-groups 'org-super-agenda-groups
                    :sort '(priority)))
        (cons "Calendar: This week"
              (lambda ()
                "Show items with an active timestamp during this calendar week."
                (interactive)
                (let* ((ts (ts-now))
                       (beg-of-week (->> ts
                                         (ts-adjust 'day (- (ts-dow (ts-now))))
                                         (ts-apply :hour 0 :minute 0 :second 0)))
                       (end-of-week (->> ts
                                         (ts-adjust 'day (- 6 (ts-dow (ts-now))))
                                         (ts-apply :hour 23 :minute 59 :second 59))))
                  (org-ql-search (org-agenda-files)
                    `(ts-active :from ,beg-of-week
                                :to ,end-of-week)
                    :title "This week"
                    :super-groups 'org-super-agenda-groups
                    :sort '(priority)))))
        (cons "Calendar: Next week"
              (lambda ()
                "Show items with an active timestamp during the next calendar week."
                (interactive)
                (let* ((ts (ts-adjust 'day 7 (ts-now)))
                       (beg-of-week (->> ts
                                         (ts-adjust 'day (- (ts-dow (ts-now))))
                                         (ts-apply :hour 0 :minute 0 :second 0)))
                       (end-of-week (->> ts
                                         (ts-adjust 'day (- 6 (ts-dow (ts-now))))
                                         (ts-apply :hour 23 :minute 59 :second 59))))
                  (org-ql-search (org-agenda-files)
                    `(ts-active :from ,beg-of-week
                                :to ,end-of-week)
                    :title "Next week"
                    :super-groups 'org-super-agenda-groups
                    :sort '(priority)))))
        (cons "Review: Recently timestamped" #'org-ql-view-recent-items)
        (cons (propertize "Review: Dangling tasks"
                          'help-echo "Tasks whose ancestor is done")
              (list :buffers-files #'org-agenda-files
                    :query '(and (todo)
                                 (ancestors (done)))
                    :title (propertize "Review: Dangling tasks"
                                       'help-echo "Tasks whose ancestor is done")
                    :sort '(todo priority date)
                    :super-groups '((:auto-parent t))))
        (cons (propertize "Review: Stale tasks"
                          'help-echo "Tasks without a timestamp in the past 2 weeks")
              (list :buffers-files #'org-agenda-files
                    :query '(and (todo)
                                 (not (ts :from -14)))
                    :title (propertize "Review: Stale tasks"
                                       'help-echo "Tasks without a timestamp in the past 2 weeks")
                    :sort '(todo priority date)
                    :super-groups '((:auto-parent t))))
        (cons (propertize "Review: Stuck projects"
                          'help-echo "Tasks with sub-tasks but no NEXT sub-tasks")
              (list :buffers-files #'org-agenda-files
                    :query '(and (todo)
                                 (descendants (todo))
                                 (not (descendants (todo "NEXT"))))
                    :title (propertize "Review: Stuck projects"
                                       'help-echo "Tasks with sub-tasks but no NEXT sub-tasks")
                    :sort '(date priority)
                    :super-groups 'org-super-agenda-groups)))
  "Alist of `org-ql-view' commands."
  :type
  '(alist
    :key-type (string :tag "Name")
    :value-type
    (choice (function :tag "Function which calls `org-ql-search'")
            (plist :tag "Org QL Search"
                   :options (((const :tag "Buffers/files" :buffers-files)
                              (choice (function-item :tag "Org Agenda Files" org-agenda-files)
                                      (repeat :tag "Buffer or file names" string)
                                      (function :tag "Function which returns a list of buffers and/or files" list)))
                             ((const :tag "Query" :query) (sexp :tag "org-ql query sexp"))
                             ((const :tag "Search title" :title) string)
                             ((const :tag "Sort-by" :sort) (repeat
                                                            (choice (const date)
                                                                    (const deadline)
                                                                    (const scheduled)
                                                                    (const todo)
                                                                    (const priority)
                                                                    (const random)
                                                                    (const reverse)
                                                                    (function :tag "Custom comparator"))))
                             ((const :tag "Group-by" :super-groups)
                              (choice (variable-item :tag "Default org-super-agenda groups" org-super-agenda-groups)
                                      (sexp :tag "org-super-agenda grouping expression")
                                      (variable :tag "Variable holding org-super-agenda  grouping expression"))))))))

(defcustom org-ql-view-relative-deadline-prefix "due "
  ;; TODO(v0.9): Add one for scheduled, too.
  "Prefix for relative deadlines.
Relative deadlines are, e.g. \"in 5d\", \"5d ago\"."
  :type 'string)

;;;; Commands

;;;###autoload
(defun org-ql-view (&optional name)
  "Choose and display the `org-ql-views' view NAME.
Interactively, prompt for NAME."
  (interactive (list (completing-read "View: " (mapcar #'car org-ql-views))))
  (let* ((view (alist-get name org-ql-views nil nil #'string=))
         (window (--find (string-prefix-p org-ql-view-buffer-name-prefix (buffer-name (window-buffer it)))
                         (window-list)))
         (org-ql-view-display-buffer-action (when (and window (not org-ql-view-display-buffer-action))
                                              (cons #'display-buffer-same-window nil))))
    (when window
      (select-window window))
    (cl-typecase view
      (function (call-interactively view))
      (list (-let* (((&plist :buffers-files :query :sort :narrow :super-groups :title) view)
                    (super-groups (cl-typecase super-groups
                                    (symbol (symbol-value super-groups))
                                    (list super-groups))))
              (org-ql-search buffers-files query
                :super-groups super-groups :narrow narrow :sort sort :title title
                :buffer org-ql-view-buffer))))))

;;;###autoload
(cl-defun org-ql-view-recent-items
    (&key num-days (type 'ts)
          (files (org-agenda-files))
          (groups '((:auto-parent t)
                    (:auto-todo t))))
  "Show items in FILES from last NUM-DAYS days with timestamps of TYPE.
TYPE may be `ts', `ts-active', `ts-inactive', `clocked', or
`closed'."
  (interactive (list :num-days (read-number "Days: ")
                     :type (->> '(ts ts-active ts-inactive clocked closed)
                                (completing-read "Timestamp type: ")
                                intern)))
  ;; It doesn't make much sense to use other date-based selectors to
  ;; look into the past, so to prevent confusion, we won't allow them.
  (-let* ((query (pcase-exhaustive type
                   ((or 'ts 'ts-active 'ts-inactive)
                    `(,type :from ,(- num-days) :to 0))
                   ((or 'clocked 'closed)
                    `(,type :from ,(- num-days) :to 0)))))
    (org-ql-search files query
      :title "Recent items"
      :sort '(todo priority date)
      :super-groups groups)))

;;;###autoload
(cl-defun org-ql-view-sidebar (&key (slot org-ql-view-list-slot))
  "Show `org-ql-view' view list sidebar.
SLOT is passed to `display-buffer-in-side-window', which see."
  ;; TODO: Update sidebar when `org-ql-views' changes.
  (interactive)
  (select-window
   (or (get-buffer-window (org-ql-view--list-buffer))
       (display-buffer-in-side-window
        (org-ql-view--list-buffer)
        (list (cons 'side org-ql-view-list-side)
              (cons 'slot slot)
              (cons 'window-parameters (list (cons 'no-delete-other-windows t)
                                             (cons 'no-other-window org-ql-view-no-other-window))))))))

(defun org-ql-view-switch ()
  "Switch to view at point."
  (interactive)
  (let ((key (buffer-substring-no-properties (pos-bol) (pos-eol))))
    (unless (string-empty-p key)
      (ov-clear :org-ql-view-selected)
      (ov (pos-bol) (1+ (pos-eol)) :org-ql-view-selected t
          'face '(:weight bold :inherit highlight))
      (org-ql-view key))))

(defun org-ql-view-refresh (&optional prompt)
  "Refresh current `org-ql-search' buffer.
If PROMPT is non-nil (interactively, with prefix), prompt to
update search arguments."
  (interactive "P")
  (unless org-ql-view-buffers-files
    (user-error "Not an Org QL View buffer"))
  (let* ((current-line (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
         (old-pos (point))
         (defaults (list org-ql-view-buffers-files
                         org-ql-view-query
                         :sort org-ql-view-sort
                         :narrow org-ql-view-narrow
                         :super-groups org-ql-view-super-groups
                         :title org-ql-view-title))
         (org-ql-view-buffer (current-buffer)))
    (if prompt
        (call-interactively #'org-ql-search)
      (apply #'org-ql-search defaults))
    ;; Now in the results buffer.
    (rename-buffer (format "%s %s*"
                           org-ql-view-buffer-name-prefix
                           (or org-ql-view-title org-ql-view-query))
                   ;; Avoid any errors in case a buffer by this name already exists.
                   'unique)
    (goto-char (point-min))
    (or (when (search-forward current-line nil t)
          (beginning-of-line))
        (goto-char old-pos))
    (message "View refreshed")))

(defun org-ql-view-save ()
  "Save current `org-ql-search' buffer to `org-ql-views'."
  (interactive)
  (let* ((name (read-string "Save view as: " org-ql-view-title))
         ;; Bind `org-ql-view-title' to the name that was read, in case
         ;; it's different, which `org-ql-view--plist' will pick up.
         (org-ql-view-title name)
         (plist (org-ql-view--plist (current-buffer))))
    (when (or (not (map-elt org-ql-views name nil))
              (yes-or-no-p (format "Overwrite view \"%s\"?" name)))
      (setf (map-elt org-ql-views name nil #'equal) plist)
      (customize-set-variable 'org-ql-views org-ql-views)
      (customize-mark-to-save 'org-ql-views)
      (custom-save-all))))

(defun org-ql-view-delete ()
  "Delete current view (with confirmation)."
  (interactive)
  (when (yes-or-no-p (format "Delete view \"%s\"?" org-ql-view-title))
    (setf org-ql-views
          (--remove (equal (car it) org-ql-view-title)
                    org-ql-views))
    (customize-set-variable 'org-ql-views org-ql-views)
    (customize-mark-to-save 'org-ql-views)
    (custom-save-all)))

(defun org-ql-view-customize ()
  "Customize view at point in `org-ql-view-sidebar' buffer."
  (interactive)
  (let ((key (buffer-substring-no-properties (pos-bol) (pos-eol))))
    (customize-option 'org-ql-views)
    (search-forward (concat "Name: " key))))

;;;; Functions

(defun org-ql-view--plist (buffer)
  "Return plist describing Org QL View in BUFFER."
  (with-current-buffer buffer
    (list :buffers-files org-ql-view-buffers-files
          :query org-ql-view-query
          :sort org-ql-view-sort
          :narrow org-ql-view-narrow
          :super-groups org-ql-view-super-groups
          :title org-ql-view-title)))

(defun org-ql-view--list-buffer ()
  "Return view list buffer."
  (with-current-buffer (get-buffer-create "*Org QL View List*")
    (use-local-map org-ql-view-list-map)
    (setf buffer-read-only t
          mode-line-format nil
          header-line-format (propertize " Org QL Views"
                                         'face 'header-line))
    (let ((inhibit-read-only t))
      (erase-buffer)
      (->> org-ql-views
           (-map #'car)
           (-sort (if org-ql-view-sidebar-sort-views
                      #'string<
                    #'ignore))
           (s-join "\n")
           insert))
    (current-buffer)))

(defvar bookmark-make-record-function)

(cl-defun org-ql-view--display (&key (buffer org-ql-view-buffer) header strings)
  "Display STRING in `org-ql-view' BUFFER.

BUFFER may be a buffer, or a string naming a buffer, which is
reused if it already exists.  `org-ql-view-buffer' is used by
default.

HEADER is a string displayed in the buffer's header line.

The following special variables, if non-nil, are set
buffer-locally to preserve their value in the buffer for
subsequent refreshing of the buffer: `org-ql-view-buffers-files',
`org-ql-view-query', `org-ql-view-sort', `org-ql-view-narrow',
`org-ql-view-super-groups', `org-ql-title.'"
  (declare (indent defun))
  (let* ((vars (list 'org-ql-view-buffers-files 'org-ql-view-query
                     'org-ql-view-sort 'org-ql-view-narrow
                     'org-ql-view-super-groups 'org-ql-view-title))
         ;; Save the values of variables which are set buffer-locally in the
         ;; results buffer, which we want to override and set buffer-locally again.
         (vals (cl-loop for symbol in vars
                        collect (cons symbol (symbol-value symbol))))
         (buffer (cl-etypecase buffer
                   (string (org-ql-view--buffer buffer))
                   (null (org-ql-view--buffer buffer))
                   (buffer buffer))))
    (with-current-buffer buffer
      (setq-local bookmark-make-record-function #'org-ql-view-bookmark-make-record)
      (use-local-map org-ql-view-map)
      ;; Prepare buffer, saving data for refreshing.
      (cl-loop for symbol in vars
               do (progn
                    (kill-local-variable symbol)
                    (set (make-local-variable symbol) (alist-get symbol vals nil nil #'equal))))
      (setf header-line-format header)
      ;; Clear buffer, insert entries, etc.
      (let ((inhibit-read-only t))
        (erase-buffer)
        (dolist (string strings)
          (insert string "\n"))
        (insert "\n")
        (pop-to-buffer (current-buffer) org-ql-view-display-buffer-action)
        (org-agenda-finalize)
        (goto-char (point-min))))))

(cl-defun org-ql-view--header-line-format (&key buffers-files query title)
  "Return `header-line-format' for BUFFERS-FILES and QUERY.
If TITLE, prepend it to the header."
  (let* ((title (if title
                    (concat (propertize "View:" 'face 'transient-argument)
                            (propertize title 'face 'org-ql-view-title)
                            " ")
                  ""))
         (query-formatted (when query
                            (org-ql-view--format-query query)))
         (query-width (when query-formatted
                        (length query-formatted)))
         (query-propertized (when query-formatted
                              (propertize (org-ql-view--font-lock-string 'emacs-lisp-mode query-formatted)
                                          'help-echo query-formatted)))
         (available-width (max 0 (- (window-width) (length "In: ")
                                    (length "Query: ") (or query-width 0)
                                    4)))
         (buffers-files-formatted (when buffers-files
                                    (format "%s" (org-ql-view--contract-buffers-files buffers-files))))
         (buffers-files-formatted (when buffers-files-formatted
                                    (propertize (->> buffers-files-formatted
                                                     (org-ql-view--font-lock-string 'emacs-lisp-mode)
                                                     (s-truncate available-width))
                                                'help-echo buffers-files-formatted))))
    (add-face-text-property 0 (length query-propertized) 'org-ql-view-query 'append query-propertized)
    (concat title
            (when query (propertize "Query:" 'face 'transient-argument))
            (when query query-propertized)
            (when query "  ")
            (when buffers-files
              (propertize "In:" 'face 'transient-argument))
            (when buffers-files-formatted
              buffers-files-formatted))))

(defun org-ql-view--format-query (query)
  "Return QUERY formatted as a string.
Makes QUERY more readable, e.g. timestamp objects are replaced
with human-readable strings."
  (cl-labels ((rec (form)
                (cl-typecase form
                  (ts (ts-format form))
                  (cons (cons (rec (car form))
                              (rec (cdr form))))
                  (otherwise form))))
    (format "%S" (rec query))))

(defun org-ql-view--font-lock-string (mode s)
  "Return string S font-locked according to MODE."
  ;; FIXME: Is this the proper way to do this?  It works, but I feel like there must be a built-in way...
  (with-temp-buffer
    (delay-mode-hooks
      (insert s)
      (funcall mode)
      (font-lock-ensure)
      (buffer-string))))

(defun org-ql-view--font-lock-as-org (s)
  "Return string S font-locked as in `org-mode'."
  ;; This works like `org-fontify-like-in-org-mode', but uses a single
  ;; buffer instead of a new one every time.
  ;; TODO(C): Submit these improvements upstream.
  (let ((buffer (or (get-buffer " *org-ql-view--font-lock-as-org*")
                    (with-current-buffer (get-buffer-create " *org-ql-view--font-lock-as-org*")
                      (buffer-disable-undo)
                      (org-mode)
                      (current-buffer)))))
    (with-current-buffer buffer
      (insert s)
      (font-lock-ensure)
      (prog1 (buffer-string)
        (erase-buffer)))))

(defun org-ql-view--buffer (&optional name)
  "Return `org-ql-view' buffer, creating it if necessary.
If NAME is non-nil, return buffer by that name instead of using
default buffer."
  (with-current-buffer (get-buffer-create (or name (concat org-ql-view-buffer-name-prefix "*")))
    (unless (eq major-mode 'org-agenda-mode)
      (org-agenda-mode)
      (setf buffer-read-only t))
    (current-buffer)))

(defun org-ql-view--format-relative-date (difference)
  ;; MAYBE: Make this a `defsubst'.
  "Return relative date string for DIFFERENCE.
DIFFERENCE should be an integer number of days, positive for
dates in the past, and negative for dates in the future."
  (cond ((> difference 0)
         (format "%sd ago" difference))
        ((< difference 0)
         (format "in %sd" (* -1 difference)))
        (t "today")))

;;;; Bookmarks

;; Support for Emacs bookmarks.

(require 'bookmark)

(defun org-ql-view-bookmark-make-record ()
  "Return a bookmark record for the current Org QL View buffer."
  (cl-labels ((file-nameize (b-f)
                (abbreviate-file-name
                 (cl-typecase b-f
                   (string b-f)
                   (buffer (or (buffer-file-name b-f)
                               (when (buffer-base-buffer b-f)
                                 (buffer-file-name (buffer-base-buffer b-f)))))
                   (t (user-error "Only file-backed buffers can be bookmarked by Org QL View: %s" b-f))))))
    (-let* ((plist (org-ql-view--plist (current-buffer)))
            ((&plist :buffers-files) plist))
      ;; Replace buffers with their filenames, and signal error if any are not file-backed.
      (setf plist (plist-put plist :buffers-files
                             (cl-etypecase buffers-files
                               (symbol buffers-files)
                               (string buffers-files)
                               (buffer (file-nameize buffers-files))
                               (list (mapcar #'file-nameize buffers-files)))))
      (list (concat "Org QL View: " org-ql-view-title)
            (cons 'org-ql-view-plist plist)
            (cons 'handler #'org-ql-view-bookmark-handler)
            (cons 'position (point))))))

;;;###autoload
(defun org-ql-view-bookmark-handler (bookmark)
  "Show Org QL View BOOKMARK in current buffer."
  ;; FIXME: `pcase-let*' is easier to use to destructure this, but if I use
  ;; that, I want to use map 2.1 for the extra convenience, but I can't force
  ;; that to be installed into the makem.sh sandbox, so I just use `-let*' here.
  (-let* ((record (bookmark-get-bookmark-record bookmark))
          ((&alist 'org-ql-view-plist) record)
          ((&plist :buffers-files :query :super-groups :narrow :sort :title)
           org-ql-view-plist)
          (super-groups (cl-etypecase super-groups
                          (symbol (symbol-value super-groups))
                          (list super-groups))))
    (org-ql-search buffers-files query
      :super-groups super-groups :narrow narrow :sort sort :title title)
    ;; HACK: `bookmark--jump-via' expects that, when the handler returns, the current buffer
    ;; (not merely the selected window's buffer) is the one to be displayed.  However,
    ;; `org-ql-view--display' uses `with-current-buffer', which resets the current buffer to
    ;; the one that was active when the bookmark was jumped to.  So we set the buffer before
    ;; returning.  It might be better to refactor `org-ql-view--display' into a function that
    ;; returns a buffer which can be displayed by the calling function.  But that would be
    ;; more complicated and might introduce bugs elsewhere, so we'll just do this for now.
    (set-buffer (window-buffer (selected-window)))))

;;;; Links

;; This section implements support for Org links to Org QL searches.  Since the
;; links are stored from and opened in `org-ql-view' buffers, this section resides
;; in this file.  However, since the links are to `org-ql-search' searches rather
;; than `org-ql-view' saved views, the link type is "org-ql-search".

(org-link-set-parameters "org-ql-search"
                         :follow #'org-ql-view--link-follow
                         :store #'org-ql-view--link-store)

;; We require the URL libraries in the functions to hopefully avoid
;; loading them until they're needed.

(eval-when-compile
  (require 'url-parse)
  (require 'url-util))

(defun org-ql-view--link-follow (path &optional _ignored)
  "Open Org QL query for current buffer at PATH.
PATH should be the part of an \"org-ql-search:\" URL after the
protocol.  See, e.g. `org-ql-view--link-store'.

The optional, second argument is temporarily _IGNORED for
purposes of compatibility with changes in Org 9.4."
  (require 'url-parse)
  (require 'url-util)
  (declare-function url-path-and-query "url-parse")
  (when (version<= "9.3" (org-version))
    ;; Org 9.3+ makes a backward-incompatible change to link escaping.
    ;; I don't think it would be a good idea to try to guess whether
    ;; the string received by this function was made with or without
    ;; that change, so we'll just test the current version of Org.
    ;; Any links created with older Org versions and then opened with
    ;; newer ones will have to be recreated.
    (setf path (url-unhex-string path)))
  (pcase-let* ((`(,query . ,params) (url-path-and-query
                                     (url-parse-make-urlobj "org-ql-search" nil nil nil nil
                                                            path)))
               (query (url-unhex-string query))
               (params (when params (url-parse-query-string params)))
               ;; `url-parse-query-string' returns "improper" alists, which makes this awkward.
               (sort (when-let* ((stored-string (car (alist-get "sort" params nil nil #'string=)))
                                 (read-value (read stored-string)))
                       ;; Ensure the value is either a symbol or list of symbols (which excludes lambdas).
                       (unless (or (symbolp read-value) (cl-every #'symbolp read-value))
                         (error "CAUTION: Link not opened because unsafe sort parameter detected: %s"
                                read-value))
                       read-value))
               (org-super-agenda-allow-unsafe-groups nil) ; Disallow unsafe group selectors.
               (groups (--when-let (car (alist-get "super-groups" params nil nil #'string=))
                         (read it)))
               (title (--when-let (car (alist-get "title" params nil nil #'string=))
                        (read it)))
               (buffers-files (--if-let (car (alist-get "buffers-files" params nil nil #'string=))
                                  (org-ql-view--expand-buffers-files (read it))
                                (current-buffer))))
    (unless (or (bufferp buffers-files)
                (stringp buffers-files)
                (cl-every #'stringp buffers-files))
      (error "CAUTION: Link not opened because unsafe buffers-files parameter detected: %s" buffers-files))
    (unless (or (stringp title) (null title))
      (error "CAUTION: Link not opened because unsafe title parameter detected: %S" title))
    (when (or (listp query)
              (string-match (rx bol (0+ space) "(") query))
      ;; SAFETY: Query is in sexp form: ask for confirmation, because it could contain arbitrary code.
      (org-ql--ask-unsafe-query query))
    (org-ql-search buffers-files query
      :sort sort
      :super-groups groups
      :title title)))

(defun org-ql-view--link-store ()
  "Store a link to the current Org QL view.
When opened, the link searches the buffer it's opened from."
  (require 'url-parse)
  (require 'url-util)
  (when org-ql-view-query
    ;; Only Org QL View buffers should have `org-ql-view-query' set.
    (cl-labels ((prompt-for (buffers-files)
                  (pcase-exhaustive
                      (completing-read (format "Make link that searches: ")
                                       '("file link is in" "files currently searched")
                                       nil t nil nil "file link is in")
                    ("file link is in" nil)
                    ("files currently searched" buffers-files)))
                (strings-or-file-buffers-p (thing)
                  (cl-etypecase thing
                    (list (cl-every #'strings-or-file-buffers-p thing))
                    (string thing)
                    (buffer (or (buffer-file-name thing)
                                ;; TODO: Should indirect buffers be allowed?  Maybe not, since their
                                ;; narrowing isn't preserved.  On the other hand, it's possible to
                                ;; accidentally make a search view for an indirect buffer that's
                                ;; since been widened, and forcing the user to manually change that
                                ;; would be awkward, and trying to communicate the problem would be
                                ;; difficult, so maybe it's okay to allow it.
                                (when (buffer-base-buffer thing)
                                  (buffer-file-name (buffer-base-buffer thing))))))))
      (unless (strings-or-file-buffers-p org-ql-view-buffers-files)
        (user-error "%s" "Views that search non-file-backed buffers can't be linked to"))
      (let* ((query-string (--if-let (org-ql--query-sexp-to-string org-ql-view-query)
                               it (org-ql-view--format-query org-ql-view-query)))
             (buffers-files (prompt-for (org-ql-view--contract-buffers-files org-ql-view-buffers-files)))
             (params (list (when buffers-files
                             (list "buffers-files" (prin1-to-string buffers-files)))
                           (when org-ql-view-super-groups
                             (list "super-groups" (prin1-to-string org-ql-view-super-groups)))
                           (when org-ql-view-sort
                             (list "sort" (prin1-to-string org-ql-view-sort)))
                           (when org-ql-view-title
                             (list "title" (prin1-to-string org-ql-view-title)))))
             (filename (concat (url-hexify-string query-string)
                               "?" (url-build-query-string (delete nil params))))
             (url (url-recreate-url (url-parse-make-urlobj "org-ql-search" nil nil nil nil
                                                           filename))))
        (org-ql-search--org-link-store-props
         :type "org-ql-search"
         :link url
         :description (concat "org-ql-search: " org-ql-view-title))))
    t))

;;;; Transient

;; This section uses `transient' to allow the user to easily modify
;; and refresh views.

;; NOTE: I don't really know what I'm doing here.  Even though the
;; Transient manual is written very well, not everything is covered in
;; it, so I'm having to try to imitate examples from `magit-transient'.

(require 'eieio-core)

(require 'transient)

(defclass org-ql-view--variable (transient-variable)
  ;; FIXME: We don't need :scope, but maybe a slot has to be defined.
  ((scope       :initarg :scope)))

(cl-defmethod transient-infix-set ((obj org-ql-view--variable) value)
  "Set Org QL View variable defined by OBJ to VALUE."
  (let ((variable (oref obj variable)))
    (oset obj value value)
    (set (make-local-variable (oref obj variable)) value)
    (unless (or value transient--prefix)
      (message "Unset %s" variable))))

(transient-define-prefix org-ql-view-dispatch ()
  "Show Org QL View dispatcher."
  [["Edit"
    ("t" org-ql-view--transient-title)
    ("q" org-ql-view--transient-query)
    ("i" org-ql-view--transient-in)
    ("s" org-ql-view--transient-sort)
    ("g" org-ql-view--transient-super-groups)]]
  [["View"
    ("r" "Refresh" org-ql-view-refresh)
    ("v" "Select" org-ql-view)]
   [""
    ("C-s" "Save" org-ql-view-save)
    ("C-k" "Delete" org-ql-view-delete)]])

(defun org-ql-view--format-transient-key-value (key value)
  "Return KEY and VALUE formatted for display in Transient."
  ;; `window-width' minus 15 is about right.  I think there's no way
  ;; to determine it automatically, because we can't know which column
  ;; Transient is starting at.
  (let ((max-width (- (window-width) 15)))
    (format "%s: %s" (propertize key 'face 'transient-argument)
            (s-truncate max-width (format "%s" value)))))

(defun org-ql-view--format-transient-lisp-argument (key value)
  "Return KEY and VALUE (a Lisp object) formatted for display in Transient."
  ;; `window-width' minus 15 is about right.  I think there's no way
  ;; to determine it automatically, because we can't know which column
  ;; Transient is starting at.
  (s-truncate (- (window-width) 15)
              (concat (propertize key 'face 'transient-argument) ": "
                      (->> value
                           org-ql-view--format-query
                           (org-ql-view--font-lock-string 'emacs-lisp-mode)))))

(transient-define-infix org-ql-view--transient-title ()
  ;; TODO: Add an asterisk or something when the view has been modified but not saved.
  :description (lambda () (org-ql-view--format-transient-key-value "Title" org-ql-view-title))
  :class 'org-ql-view--variable
  :argument ""
  :variable 'org-ql-view-title
  :prompt "Title: "
  :reader (lambda (prompt _initial-input history)
            ;; FIXME: Figure out how to integrate initial-input.
            (read-string prompt (when org-ql-view-title
                                  (format "%s" org-ql-view-title))
                         history)))

(transient-define-infix org-ql-view--transient-query ()
  :description (lambda () (org-ql-view--format-transient-lisp-argument "Query" org-ql-view-query))
  :class 'org-ql-view--variable
  :argument ""
  :variable 'org-ql-view-query
  :prompt "Query: "
  :reader (lambda (prompt _initial-input history)
            ;; FIXME: Figure out how to integrate initial-input.
            (let ((query (read-string prompt (when org-ql-view-query
                                               (format "%S" org-ql-view-query))
                                      history)))
              (if (or (string-prefix-p "(" query)
                      (string-prefix-p "\"" query))
                  ;; Read sexp query.
                  (read query)
                ;; Parse non-sexp query into sexp query.
                (org-ql--query-string-to-sexp query)))))

(transient-define-infix org-ql-view--transient-in ()
  :description (lambda () (org-ql-view--format-transient-lisp-argument "In buffers/files" org-ql-view-buffers-files))
  :class 'org-ql-view--variable
  :argument ""
  :variable 'org-ql-view-buffers-files
  :prompt "Buffers/files: "
  :reader (lambda (_prompt _initial-input _history)
            ;; This doesn't use the Transient `initial-input'
            ;; argument, but it gives the same result.
            (org-ql-view--complete-buffers-files)))

(transient-define-infix org-ql-view--transient-super-groups ()
  :description (lambda ()
                 (org-ql-view--format-transient-lisp-argument "Group by" org-ql-view-super-groups))
  :class 'org-ql-view--variable
  :argument ""
  :variable 'org-ql-view-super-groups
  :prompt "Group by: "
  :reader (lambda (_prompt _initial-input _history)
            ;; FIXME: Figure out how to integrate initial-input and history.
            (org-ql-view--complete-super-groups)))

(transient-define-infix org-ql-view--transient-sort ()
  :description
  (lambda ()
    (org-ql-view--format-transient-lisp-argument "Sort by" (or org-ql-view-sort 'buffer-order)))
  :class 'org-ql-view--variable
  :argument ""
  :variable 'org-ql-view-sort
  :prompt "Sort: "
  :reader (lambda (_prompt _initial-input _history)
            ;; FIXME: Figure out how to integrate initial-input and history.
            (org-ql-view--complete-sort)))

;;;; Faces/properties

(defalias 'org-ql-view--resolve-element-properties
  ;; It would be preferable to define this as an inline function, but
  ;; that would mean that users would have to recompile org-ql when
  ;; upgrading to Org 9.7 or else get weird errors.
  ;; TODO(someday): Define `org-ql-view--resolve-element-properties' as inline.
  (if (version<= "9.7" org-version)
      (lambda (node)
        "Resolve NODE's properties using `org-element-properties-resolve'."
        ;; Silence warnings about `org-element-properties-resolve'
        ;; being unresolved on earlier Org versions.
        (with-no-warnings
          (org-element-properties-resolve node 'force-undefer)))
    #'identity))

(defun org-ql-view--format-element (element)
  ;; This essentially needs to do what `org-agenda-format-item' does,
  ;; which is a lot.  We are a long way from that, but it's a start.
  "Return ELEMENT as a string with text-properties set by its property list.
Its property list should be the second item in the list, as
returned by `org-element-parse-buffer'.  If ELEMENT is nil,
return an empty string."
  (if (not element)
      ""
    (setf element (org-ql-view--resolve-element-properties element))
    (let* ((properties (cadr element))
           ;; Remove the :parent property, which so bloats the size of
           ;; the properties list that it makes it essentially
           ;; impossible to debug, because Emacs takes approximately
           ;; forever to show it in the minibuffer or with
           ;; `describe-text-properties'.  FIXME: Shouldn't be necessary
           ;; anymore since we're not parsing the whole buffer.

           ;; Also, remove ":" from key symbols.  FIXME: It would be
           ;; better to avoid this somehow.  At least, we should use a
           ;; function to convert plists to alists, if possible.
           (properties (cl-loop for (key val) on properties by #'cddr
                                for symbol = (intern (cl-subseq (symbol-name key) 1))
                                unless (member symbol '(parent))
                                append (list symbol val)))
           ;; TODO: --add-faces is used to add the :relative-due-date property, but that fact is
           ;; hidden by doing it through --add-faces (which calls --add-scheduled-face and
           ;; --add-deadline-face), and doing it in this form that gets the title hides it even more.
           ;; Adding the relative due date property should probably be done explicitly and separately
           ;; (which would also make it easier to do it independently of faces, etc).
           (title (--> (org-ql-view--add-faces element)
                       (org-element-property :raw-value it)))
           ;; TODO(B): Needs refactoring.  A function like `org-ql-view--add-faces'
           ;; should return a list of faces to be added.
           (title-faces (get-text-property 0 'face title))
           (title (org-ql-view--font-lock-as-org title))
           (_ (add-face-text-property 0 (length title) title-faces t title))
           (todo-keyword (-some--> (org-element-property :todo-keyword element)
                           (org-ql-view--add-todo-face
                            (substring-no-properties it))))
           (tag-list (if org-use-tag-inheritance
                         ;; MAYBE: Use our own variable instead of `org-use-tag-inheritance'.
                         (if-let ((marker (or (org-element-property :org-hd-marker element)
                                              (org-element-property :org-marker element))))
                             (with-current-buffer (marker-buffer marker)
                               (org-with-wide-buffer
                                (goto-char marker)
                                (cl-loop for type in (org-ql--tags-at marker)
                                         unless (or (eq 'org-ql-nil type)
                                                    (not type))
                                         append type)))
                           ;; No marker found
                           (display-warning 'org-ql (format "No marker found for item: %s" title))
                           (org-element-property :tags element))
                       (org-element-property :tags element)))
           (tag-string (when tag-list
                         (--> tag-list
                              (s-join ":" it)
                              (s-wrap it ":")
                              (org-add-props it nil 'face 'org-tag))))
           (category (or (org-element-property :CATEGORY element)
                         (when-let ((marker (or (org-element-property :org-hd-marker element)
                                                (org-element-property :org-marker element))))
                           (org-with-point-at marker
                             (or (org-get-category)
                                 (when buffer-file-name
			           (file-name-sans-extension
			            (file-name-nondirectory buffer-file-name))))))
                         ""))
           (priority-string (-some->> (org-element-property :priority element)
                              (char-to-string)
                              (format "[#%s]")
                              (org-ql-view--add-priority-face)))
           (habit-property (org-with-point-at (or (org-element-property :org-hd-marker element)
                                                  (org-element-property :org-marker element))
                             (when (org-is-habit-p)
                               (org-habit-parse-todo))))
           (due-string (pcase (org-element-property :relative-due-date element)
                         ('nil "")
                         (string (format " %s " (org-add-props string nil 'face 'org-ql-view-due-date)))))
           (string (s-join " " (-non-nil (list todo-keyword priority-string title due-string tag-string)))))
      (remove-list-of-text-properties 0 (length string) '(line-prefix) string)
      ;; Add all the necessary properties and faces to the whole string
      (--> string
           ;; FIXME: Use proper prefix
           (concat "  " it)
           (org-add-props it properties
             'org-agenda-type 'search
             'org-category category
             'todo-state todo-keyword
             'tags tag-list
             'org-habit-p habit-property)))))

(defun org-ql-view--add-faces (element)
  "Return ELEMENT with deadline and scheduled faces added."
  (->> element
       (org-ql-view--add-scheduled-face)
       (org-ql-view--add-deadline-face)))

(defun org-ql-view--add-priority-face (string)
  "Return STRING with priority face added."
  (when (string-match "\\(\\[#\\(.\\)\\]\\)" string)
    (let ((face (org-get-priority-face (string-to-char (match-string 2 string)))))
      (org-add-props string nil 'face face 'font-lock-fontified t))))

(defun org-ql-view--add-scheduled-face (element)
  "Add faces to ELEMENT's title for its scheduled status."
  ;; NOTE: Also adding prefix
  (if-let ((scheduled-date (org-element-property :scheduled element)))
      (let* ((todo-keyword (org-element-property :todo-keyword element))
             (today-day-number (org-today))
             ;; (current-day-number
             ;; NOTE: Not currently used, but if we ever implement a more "traditional" agenda that
             ;; shows perspective of multiple days at once, we'll need this, so I'll leave it for now.
             ;;  ;; FIXME: This is supposed to be the, shall we say,
             ;;  ;; pretend, or perspective, day number that this pass
             ;;  ;; through the agenda is being made for.  We need to
             ;;  ;; either set this in the calling function, set it here,
             ;;  ;; or accomplish this in a different way.  See
             ;;  ;; `org-agenda-get-scheduled' and where `date' is set in
             ;;  ;; `org-agenda-list'.
             ;;  today-day-number)
             (scheduled-day-number (org-time-string-to-absolute
                                    (org-element-timestamp-interpreter scheduled-date 'ignore)))
             (difference-days (- today-day-number scheduled-day-number))
             (relative-due-date (org-add-props (org-ql-view--format-relative-date difference-days) nil
                                  'help-echo (org-element-property :raw-value scheduled-date)))
             ;; FIXME: Unused for now:
             ;; (show-all (or (eq org-agenda-repeating-timestamp-show-all t)
             ;;               (member todo-keyword org-agenda-repeating-timestamp-show-all)))
             ;; FIXME: Unused for now: (sexp-p (string-prefix-p "%%" raw-value))
             ;; FIXME: Unused for now: (raw-value (org-element-property :raw-value scheduled-date))
             ;; FIXME: I don't remember what `repeat-day-number' was for, but we aren't using it.
             ;; But I'll leave it here for now.
             ;; (repeat-day-number (cond (sexp-p (org-time-string-to-absolute scheduled-date))
             ;;                          ((< today-day-number scheduled-day-number) scheduled-day-number)
             ;;                          (t (org-time-string-to-absolute
             ;;                              raw-value
             ;;                              (if show-all
             ;;                                  current-day-number
             ;;                                today-day-number)
             ;;                              'future
             ;;                              ;; FIXME: I don't like
             ;;                              ;; calling `current-buffer'
             ;;                              ;; here.  If the element has
             ;;                              ;; a marker, we should use
             ;;                              ;; that.
             ;;                              (current-buffer)
             ;;                              (org-element-property :begin element)))))
             (face (cond ((member todo-keyword org-done-keywords) 'org-agenda-done)
                         ((= today-day-number scheduled-day-number) 'org-scheduled-today)
                         ((> today-day-number scheduled-day-number) 'org-scheduled-previously)
                         (t 'org-scheduled)))
             (title (--> (org-element-property :raw-value element)
                         (org-add-props it nil
                           'face face)))
             (properties (--> (cadr element)
                              (plist-put it :title title)
                              (plist-put it :relative-due-date relative-due-date))))
        (list (car element)
              properties))
    ;; Not scheduled
    element))

(defun org-ql-view--add-deadline-face (element)
  "Add faces to ELEMENT's title for its deadline status.
Also store relative due date as string in `:relative-due-date'
property."
  ;; FIXME: In my config, doesn't apply orange for approaching deadline the same way the Org Agenda does.
  (if-let ((deadline-date (org-element-property :deadline element)))
      (let* ((today-day-number (org-today))
             (deadline-day-number (org-time-string-to-absolute
                                   (org-element-timestamp-interpreter deadline-date 'ignore)))
             (difference-days (- today-day-number deadline-day-number))
             (relative-due-date (org-add-props
                                    (concat org-ql-view-relative-deadline-prefix
                                            (org-ql-view--format-relative-date difference-days)) nil
                                  'help-echo (org-element-property :raw-value deadline-date)))
             ;; FIXME: Unused for now: (todo-keyword (org-element-property :todo-keyword element))
             ;; FIXME: Unused for now: (done-p (member todo-keyword org-done-keywords))
             ;; FIXME: Unused for now: (today-p (= today-day-number deadline-day-number))
             (deadline-passed-fraction (--> (- deadline-day-number today-day-number)
                                            (float it)
                                            (/ it (max org-deadline-warning-days 1))
                                            (- 1 it)))
             (face (org-agenda-deadline-face deadline-passed-fraction))
             (title (--> (org-element-property :raw-value element)
                         (org-add-props it nil
                           'face face)))
             (properties (--> (cadr element)
                              (plist-put it :title title)
                              (plist-put it :relative-due-date relative-due-date))))
        (list (car element)
              properties))
    ;; No deadline
    element))

(defun org-ql-view--add-todo-face (keyword)
  "Return KEYWORD with Org to-do face added."
  (let* ((org-done-keywords org-done-keywords-for-agenda)
         (face (org-get-todo-face keyword)))
    (when face
      (add-text-properties 0 (length keyword) (list 'face face) keyword))
    keyword))

;;;;; 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.

(declare-function org-ql-search-directories-files "org-ql-search" t)

(defun org-ql-view--contract-buffers-files (buffers-files)
  "Return BUFFERS-FILES in its \"contracted\" form.
The contracted form is \"org-agenda-files\" if BUFFERS-FILES
matches the value of `org-agenda-files' (either the function or
the variable), \"org-directory\" if it matches the value of
`org-ql-search-directories-files', or \"buffer\" if it is the
current buffer.  Otherwise BUFFERS-FILES is returned unchanged."
  ;; Used in `org-ql-view--complete-buffers-files' and
  ;; `org-ql-view--header-line-format'.
  (cl-labels ((expand-files (list)
                (--map (cl-typecase it
                         (string (expand-file-name it))
                         (otherwise it))
                       list)))
    ;; TODO: Test this more exhaustively.
    (pcase buffers-files
      ((pred listp)
       (pcase (expand-files buffers-files)
         ((pred (seq-set-equal-p (mapcar #'expand-file-name (org-agenda-files))))
          "org-agenda-files")
         ((and (guard (file-exists-p org-directory))
               (pred (seq-set-equal-p (org-ql-search-directories-files
                                       :directories (list org-directory)))))
          "org-directory")
         (_ buffers-files)))
      ((pred (equal (current-buffer)))
       "buffer")
      ((or 'org-agenda-files '(function org-agenda-files))
       "org-agenda-files")
      ((and (pred bufferp) (guard (buffer-file-name buffers-files)))
       (buffer-file-name buffers-files))
      (_ buffers-files))))

(defun org-ql-view--complete-buffers-files ()
  "Return value for `org-ql-view-buffers-files' using completion."
  (cl-labels ((initial-input ()
                (when org-ql-view-buffers-files
                  (org-ql-view--contract-buffers-files
                   org-ql-view-buffers-files))))
    (if (and org-ql-view-buffers-files
             (bufferp org-ql-view-buffers-files))
        ;; 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.
        org-ql-view-buffers-files
      (org-ql-view--expand-buffers-files
       (completing-read "Buffers/Files: "
                        (list 'buffer 'org-agenda-files 'org-directory 'all)
                        nil nil (initial-input))))))

(defun org-ql-view--expand-buffers-files (buffers-files)
  "Return BUFFERS-FILES expanded to a list of files or buffers.
The counterpart to `org-ql-view--contract-buffers-files'."
  (pcase-exhaustive buffers-files
    ("all" (--select (equal (buffer-local-value 'major-mode it) 'org-mode)
                     (buffer-list)))
    ("org-agenda-files" (org-agenda-files))
    ("org-directory" (org-ql-search-directories-files))
    ((or "" "buffer") (current-buffer))
    ((pred bufferp) buffers-files)
    ((pred listp) buffers-files)
    ;; A single filename.
    ((pred stringp) buffers-files)))

(defun org-ql-view--complete-super-groups ()
  "Return value for `org-ql-view-super-groups' using completion."
  (when (bound-and-true-p org-super-agenda-auto-selector-keywords)
    (let ((keywords (cl-loop for type in org-super-agenda-auto-selector-keywords
                             collect (substring (symbol-name type) 6))))
      (pcase (completing-read "Group by: "
                              (append (list "Don't group"
                                            "Global super-groups")
                                      keywords)
                              nil nil (when org-ql-view-super-groups
                                        (format "%S" org-ql-view-super-groups)))
        ("Global super-groups" org-super-agenda-groups)
        ((or "" "Don't group") nil)
        ((and keyword (guard (member keyword keywords)))
         (list (list (intern (concat ":auto-" keyword)))))
        (else (read else))))))

(defun org-ql-view--complete-sort ()
  "Return value for `org-ql-view-sort' using completion."
  ;; Use space to separate sorting predicates, not comma.
  (let* ((crm-separator (rx space))
         (crm-local-completion-map (let ((map (copy-keymap crm-local-completion-map)))
                                     (define-key map (kbd "SPC") nil)
                                     map))
         (input (->> (completing-read-multiple "Sort by: "
                                               (list "buffer-order"
                                                     "date"
                                                     "deadline"
                                                     "priority"
                                                     "random"
                                                     "reverse"
                                                     "scheduled"
                                                     "todo")
                                               nil nil (when org-ql-view-sort
                                                         (prin1-to-string org-ql-view-sort)))
                     (--remove (equal "buffer-order" it)))))
    (pcase input
      ('nil nil)
      ((and (pred listp) sort)
       ;; Multiple sorters.
       (mapcar #'intern sort))
      (sort ;; One sorter.
       (intern sort)))))

;;;; Footer

(provide 'org-ql-view)

;;; org-ql-view.el ends here
