zk / Task View

(require 'org-zk-core)
(require 'org-zk-query)

(defface org-zk-task-view-effort-face
  '((((class color) (background light)) (:foreground "#aaa"))
    (((class color) (background dark))  (:foreground "#77a")))
  "Face used for dates in the file view."
  :group 'org-zk)

(defun org-zk-task-view--sort-todo-keyword (kw)
  (cond
   ((string= kw "NEXT") 6)
   ((string= kw "TODO") 5)
   ((string= kw "WAITING") 4)
   ((string= kw "DONE") 3)
   ((string= kw "DELEGATED") 2)
   ((string= kw "CANCELLED") 1)
   (t 0)))

;; TODO: Use default priority variable
(defun org-zk-task-view--sort-priority (prio)
  (cond
   ((eql prio ?A) 3)
   ((eql prio ?B) 2)
   ((eql prio ?C) 1)
   (t 0)))

(defvar org-zk-task-view--sort-predicates
  (list
   (list (lambda (e) (org-zk-task-view--sort-todo-keyword (plist-get e :todo-keyword))) #'> #'<)
   (list (lambda (e) (org-zk-task-view--sort-priority
                 (or (plist-get e :priority) org-default-priority))) #'> #'<)
   ;; (list (lambda (e) (org-el-cache-get-keyword (oref e parent) "TITLE")) #'string> #'string<)
   (list (lambda (e) (plist-get e :title)) #'string> #'string<)))

;; Keyword
;; Prio
;; Title
(cl-defun org-zk-task-view--sort-predicate (a b &optional (predicates org-zk-task-view--sort-predicates))
  (message "sorting")
  (if (null predicates)
      nil
    (let* ((pred (car predicates))
           (va (funcall (first pred) a))
           (vb (funcall (first pred) b)))
      (cond
       ((funcall (second pred) va vb) t)
       ((funcall (third pred) va vb) nil)
       (t (org-zk-task-view--sort-predicate a b (cdr predicates)))))))

(defun org-zk-task-view--sort (headlines)
  (sort headlines #'org-zk-task-view--sort-predicate))

(defvar org-zk-task-view-format
  (vector
   '("Todo" 8 t)
   '("P" 1 t)
   '("Project" 20 t)
   '("Effort" 6 t)
   '("Title" 40 t)))

(defun org-zk-task-view-tabulate-title (hl)
  (if (null (plist-get hl :tags))
      (propertize
       (plist-get hl :title)
       'face 'org-zk-file-view-title-face)
    (concat
     (propertize
      (plist-get hl :title)
      'face 'org-zk-file-view-title-face)
     " ("
     (mapconcat
      (lambda (tag) (propertize tag 'face 'org-zk-file-view-keyword-face))
      (plist-get hl :tags) ",")
     ")")))

(defun org-zk-task-view-tabulate-todo-keyword (kw)
  (if (null kw)
      ""
      (propertize (substring-no-properties kw) 'face (org-get-todo-face kw))))

(defun org-zk-task-view-tabulate-priority (p)
  (cond
   ((equal p org-highest-priority)
    (propertize (format "%c" p) 'face 'bold))
   ;; ((equal p org-lowest-priority)
   ;;  (propertize (format "%c" p) 'face 'italic))
   (t (format "%c" p))))

(defun org-zk-task-view-tabulate-effort (e)
  (propertize e 'face 'org-zk-task-view-effort-face))

;; Works on a list of (file-entry . hl) pairs
(defun org-zk-task-view-tabulate (file-hls)
  (mapcar
   (lambda (file-hl)
     (list
      file-hl
      (vector
       (org-zk-task-view-tabulate-todo-keyword
        (plist-get (cdr file-hl) :todo-keyword))
       (org-zk-task-view-tabulate-priority
        (or (plist-get (cdr file-hl) :priority) org-default-priority))
       (plist-get (car file-hl) :title)
       (org-zk-task-view-tabulate-effort
        (or (plist-get (cdr file-hl) :effort) ""))
       (org-zk-task-view-tabulate-title (cdr file-hl)))))
   file-hls))

(setq org-zk-task-view-contexts
  '(("NEXT" "s:active" "k:NEXT")
    ("uni" "s:active" "k:NEXT t:uni")
    ("zk" "s:active" "k:NEXT t:zk")
    ("habit" "s:active" "k:NEXT t:habit")))

(defun org-zk-task-view ()
  (interactive)
  (org-zk-task-view-show "s:active" "k:NEXT"))

(defun org-zk-task-view-switch-context (context)
  "Switch to a predefined task context."
  (interactive (list (completing-read "Context: " org-zk-task-view-contexts nil 'require-match)))
  (if (stringp context)
      (setq context (cdr (assoc context org-zk-task-view-contexts))))
  (apply #'org-zk-task-view-show context))

(defmacro org-zk-task-view-at-entry (entry &rest body)
  "Execute BODY at the headline / file of ENTRY.
Throws an error if ENTRY has no id or if its id can't be found in
the target file."
  (declare (indent defun))
  `(let ((file (plist-get (car ,entry) :file))
         (id (plist-get (cdr ,entry) :id)))
     (if (null id)
         (error "Headline entry has no id")
       (org-zk-in-file file
         (let ((position (org-id-find-id-in-file id file)))
           (if position
               (progn (goto-char (cdr position))
                      ,@body)
             (error "ID %s not found in %s" id file)))))))

(defun org-zk-task-view-set-effort ()
  (interactive)
  (let* ((id (tabulated-list-get-id))
         (file (plist-get (car id) :file))
         (cur (plist-get (cdr id) :effort))
         (allowed (org-property-get-allowed-values nil org-effort-property))
         (effort (org-quickselect-effort-prompt cur allowed)))
    (org-zk-task-view-at-entry id
      (org-set-effort nil effort))
    (tabulated-list-set-col
     "Effort"
     (org-zk-task-view-tabulate-effort effort))))

(defun org-zk-task-view-set-priority ()
  (interactive)
  (let* ((id (tabulated-list-get-id))
         (file (plist-get (car id) :file)))
    ;; `org-priority' doesn't return a value, so we have to get the
    ;; new priority by hand
    (let ((priority
           (org-zk-task-view-at-entry id
             (call-interactively 'org-priority)
             (fourth (org-heading-components)))))
      (tabulated-list-set-col
       "P"
       (org-zk-task-view-tabulate-priority priority)))))

(defun org-zk-task-view-set-todo ()
  (interactive)
  (let* ((id (tabulated-list-get-id))
         (file (plist-get (car id) :file)))
    (let  ((todo
            (org-zk-task-view-at-entry id
              (call-interactively 'org-todo)
              (third (org-heading-components)))))
      (tabulated-list-set-col
       "Todo"
       (org-zk-task-view-tabulate-todo-keyword todo)))))

(define-derived-mode org-zk-task-view-mode tabulated-list-mode "org-zk Tasks"
  "Major mode for listing org tasks"
  (hl-line-mode))

(setq org-zk-task-view-mode-map
      (let ((map (make-sparse-keymap)))
        (set-keymap-parent map tabulated-list-mode-map)
        (define-key map (kbd "c") 'org-zk-task-view-switch-context)
        (define-key map (kbd "/") 'org-zk-task-view-edit-headline-filter)
        (define-key map (kbd "RET") 'org-zk-task-view-open)
        (define-key map (kbd "e") 'org-zk-task-view-set-effort)
        (define-key map (kbd "t") 'org-zk-task-view-set-todo)
        (define-key map (kbd ",") 'org-zk-task-view-set-priority)
        map))

(defun org-zk-task-view-open ()
  (interactive)
  (let ((file-hl (tabulated-list-get-id)))
    (find-file (plist-get (car file-hl) :file))
    (goto-char (plist-get (cdr file-hl) :begin))
    (org-reveal)))

(defun org-zk-task-view-tasks (file-pred hl-pred)
  (let (headlines)
    (org-el-cache-each
     org-zk-cache
     (lambda (filename entry)
       (if (funcall file-pred filename entry)
           (dolist (hl (plist-get entry :headlines))
             (if (and (plist-get hl :todo-keyword)
                      (funcall hl-pred filename hl))
                 (push (cons entry hl) headlines))))))
    headlines))

(defun org-zk-task-view-buffer ()
  (get-buffer-create "*org-zk Tasks*"))

(defvar org-zk-task-view--file-filter nil)
(defvar org-zk-task-view--headline-filter nil)

(defun org-zk-task-view-show (file-filter hl-filter)
  (org-zk-cache-update)
  (setq org-zk-task-view--file-filter file-filter)
  (setq org-zk-task-view--headline-filter hl-filter)
  (let ((file-hls
         (org-zk-task-view-tasks
          (org-zk-query file-filter org-zk-query-file-predicates)
          (org-zk-query hl-filter org-zk-query-hl-predicates))))
    (with-current-buffer (org-zk-task-view-buffer)
      (org-zk-task-view-mode)
      (setq tabulated-list-format org-zk-task-view-format)
      (tabulated-list-init-header)
      (setq tabulated-list-entries (org-zk-task-view-tabulate file-hls))
      (setq tabulated-list-sort-key nil)
      (tabulated-list-print)
      (switch-to-buffer (current-buffer)))))

(defun org-zk-task-view-edit-file-filter ()
  "Edit file filter."
  (interactive)
  (let ((file-filter (read-string "File Filter: " org-zk-task-view--file-filter)))
    (org-zk-task-view-show file-filter org-zk-task-view--headline-filter)))

(defun org-zk-task-view-edit-headline-filter ()
  "Edit headline filter."
  (interactive)
  (let ((headline-filter (read-string "File Filter: " org-zk-task-view--headline-filter)))
    (org-zk-task-view-show org-zk-task-view--file-filter headline-filter)))

(provide 'org-zk-task-view)