org-clock-agg/org-clock-agg.el

717 lines
27 KiB
EmacsLisp

;;; org-clock-agg.el --- Aggregate org-clock statistics -*- lexical-binding: t -*-
;; Copyright (C) 2023 Korytov Pavel
;; Author: Korytov Pavel <thexcloud@gmail.com>
;; Maintainer: Korytov Pavel <thexcloud@gmail.com>
;; Version: 0.1.0
;; Package-Requires: ((emacs "27.1") (compat "29.1.4.1") (org-ql "0.8-pre"))
;; Homepage: https://github.com/SqrtMinusOne/org-clock-agg
;; This file is NOT part of GNU Emacs.
;; 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:
;; TODO
;;; Code:
(require 'cl-lib)
(require 'font-lock)
(require 'outline)
(require 'org)
(require 'seq)
(require 'widget)
(require 'compat)
(require 'org-ql)
(defgroup org-clock-agg nil
"Aggregate org-clock statistics."
:group 'org-clock)
(defcustom org-clock-agg-duration-format "%h:%.2m"
"Format string for durations in org-clock-agg views.
See `format-seconds' for the list of available format specifiers."
:type 'string
:group 'org-clock-agg)
(defcustom org-clock-agg-files-preset nil
"Presets for the \"files\" parameter in org-clock-agg views."
:type '(alist :key-type string :value-type (repeat string))
:group 'org-clock-agg)
(defcustom org-clock-agg-day-format "%Y-%m-%d, %a"
"Format string for days in org-clock-agg views.
See `format-time-string' for the list of available format specifiers."
:type 'string
:group 'org-clock-agg)
(defcustom org-clock-agg-week-format "%Y-%W"
"Format string for weeks in org-clock-agg views.
See `format-time-string' for the list of available format specifiers."
:type 'string
:group 'org-clock-agg)
(defcustom org-clock-agg-month-format "%Y-%m"
"Format string for months in org-clock-agg views.
See `format-time-string' for the list of available format specifiers."
:type 'string
:group 'org-clock-agg)
(defface org-clock-agg-group-face
'((t :inherit font-lock-comment-face))
"Face for group names in org-clock-agg tree views."
:group 'org-clock-agg)
(defface org-clock-agg-duration-face
'((t :inherit font-lock-constant-face))
"Face for durations in org-clock-agg tree views."
:group 'org-clock-agg)
(defface org-clock-agg-param-face
'((t :inherit font-lock-variable-name-face))
"Face for parameters in org-clock-agg tree views."
:group 'org-clock-agg)
(defface org-clock-agg-elem-face nil
"Face for elements in org-clock-agg tree views.
It's probably supposed to be nil because it overrides the default
element formatting."
:group 'org-clock-agg)
;; Reset org-ql cache
(setq org-ql-cache (make-hash-table :weakness 'key))
(setq org-clock-agg-groupby nil)
(setq org-clock-agg-sort nil)
;;; Querying
(defun org-clock-agg--parse-clocks (headline)
(let ((contents (buffer-substring-no-properties
(org-element-property :contents-begin headline)
(org-element-property :contents-end headline))))
(with-temp-buffer
(insert contents)
(let (res)
(org-element-map (org-element-parse-buffer) 'clock
(lambda (clock)
(let ((start (time-convert
(org-timestamp-to-time (org-element-property :value clock))
'integer))
(end (time-convert
(org-timestamp-to-time (org-element-property :value clock) t)
'integer)))
(push
`((:start . ,start)
(:end . ,end)
(:duration . ,(- end start)))
res)))
nil nil 'headline)
res))))
(defun org-clock-agg--parse-headline ()
(let* ((headline (org-element-headline-parser))
(tags-val (org-ql--tags-at (point)))
(tags (seq-filter
#'stringp ;; to filter out `org-ql-nil'
(append (unless (eq (car tags-val) 'org-ql-nil)
(car tags-val))
(unless (eq (cdr tags-val) 'org-ql-nil)
(cdr tags-val)))))
(file (buffer-file-name))
(outline-path (mapcar
#'substring-no-properties
(org-ql--outline-path)))
(category (org-get-category)))
(org-ql--add-markers headline)
(cl-loop for clock in (org-clock-agg--parse-clocks headline)
collect`(,@clock
(:headline . ,headline)
(:tags . ,tags)
(:file . ,file)
(:outline-path . ,outline-path)
(:category . ,category)))))
(defun org-clock-agg--query (from to files)
(cl-loop for res in (org-ql-query
:select #'org-clock-agg--parse-headline
:from files
:where `(clocked :from ,from :to ,to))
append res))
;;; Aggregation
(defvar org-clock-agg-groupby nil
"Group by functions.")
(defvar org-clock-agg-sort nil
"Sort functions.")
;; XXX This looks like reinventing the wheel... IDK.
(defmacro org-clock-agg--extract-params (body &rest params)
`(let ((body-wo-docstring (if (stringp (car-safe body)) (cdr body) body))
(docstring (when (stringp (car-safe body)) (car-safe body))))
(while-let ((symbol (and
(member (car-safe body-wo-docstring) ',params)
(car-safe body-wo-docstring))))
,@(mapcar
(lambda (param)
`(when (eq symbol ,param)
(setq ,(intern (substring (symbol-name param) 1)) (cadr body-wo-docstring))))
params)
(setq body-wo-docstring (cddr body-wo-docstring)))
(if docstring
(setq body (cons docstring body-wo-docstring))
(setq body body-wo-docstring))))
(cl-defmacro org-clock-agg-defgroupby (name &body body)
(declare (indent defun)
(doc-string 2))
(let ((func-name (intern (concat "org-clock-agg--groupby-" (symbol-name name))))
readable-name hidden default-sort)
;; Parse keyword arguments in BODY
(org-clock-agg--extract-params body :readable-name :hidden
:default-sort)
(unless readable-name
(setq readable-name (symbol-name name)))
`(progn
(defun ,func-name (elem)
,@body)
(push (cons ',name '((:symbol . ,name)
(:function . ,func-name)
(:hidden . ,hidden)
(:readable-name . ,readable-name)
(:default-sort . ,default-sort)))
org-clock-agg-groupby))))
(cl-defmacro org-clock-agg-defsort (name &body body)
(declare (indent defun)
(doc-string 2))
(let ((func-name (intern (concat "org-clock-agg--sort-" (symbol-name name))))
readable-name)
(org-clock-agg--extract-params body :readable-name)
(unless readable-name
(setq readable-name (symbol-name name)))
`(progn
(defun ,func-name (nodes)
,@body)
(push (cons ',name '((:function . ,func-name)
(:readable-name . ,readable-name)))
org-clock-agg-sort))))
(org-clock-agg-defgroupby category
"Group org-clock entries by category."
:readable-name "Category"
:default-sort total
(list (alist-get :category elem)))
(org-clock-agg-defgroupby org-file
"Group org-clock entries by file in `org-directory'."
:readable-name "Org file"
:default-sort total
(list
(file-relative-name (alist-get :file elem)
(directory-file-name org-directory))))
(org-clock-agg-defgroupby outline-path
"Group org-clock entries by outline path."
:readable-name "Outline path"
:default-sort total
(alist-get :outline-path elem))
(org-clock-agg-defgroupby tags
"Group org-clock entries by tags."
:readable-name "Tags"
:default-sort total
(seq-sort
#'string-lessp
(alist-get :tags elem)))
(org-clock-agg-defgroupby headline
"Group org-clock entries by headline."
:readable-name "Headline"
:default-sort total
(list (org-element-property :raw-value (alist-get :headline elem))))
(org-clock-agg-defgroupby day
:readable-name "Day"
:default-sort start-time
(list (thread-last elem
(alist-get :start)
(seconds-to-time)
(format-time-string org-clock-agg-day-format))))
(org-clock-agg-defgroupby week
:readable-name "Week"
:default-sort start-time
(list (thread-last elem
(alist-get :start)
(seconds-to-time)
(format-time-string org-clock-agg-week-format))))
(org-clock-agg-defgroupby month
:readable-name "Month"
:default-sort start-time
(list (thread-last elem
(alist-get :start)
(seconds-to-time)
(format-time-string org-clock-agg-month-format))))
(org-clock-agg-defgroupby todo
:readable-name "TODO keyword"
:default-sort total
(list (substring-no-properties
(org-element-property :todo-keyword (alist-get :headline elem)))))
(org-clock-agg-defgroupby is-done
:readable-name "Is done"
:default-sort total
(list (if (eq (org-element-property :todo-type (alist-get :headline elem)) 'done)
"Done"
"Not done")))
(org-clock-agg-defgroupby root-group
"Return \"Root\". Used for the root group."
:readable-name "Root"
:default-sort total
:hidden t
(list "Results"))
(org-clock-agg-defsort name
"Sort by name."
:readable-name "Name"
(seq-sort-by (lambda (elem) (alist-get :name elem)) #'string-lessp nodes))
(org-clock-agg-defsort total
"Sort by total time spent."
:readable-name "Total time"
(seq-sort-by (lambda (elem) (alist-get :total elem)) #'> nodes))
(org-clock-agg-defsort start-time
"Sort by start time."
:readable-name "Start time"
(seq-sort-by
(lambda (elem)
(thread-last elem
(list)
(org-clock-agg--ungroup)
(mapcar (lambda (row-elem) (alist-get :start row-elem)))
(seq-min)))
#'> nodes))
(org-clock-agg-defsort end-time
"Sort by end time."
:readable-name "End time"
(seq-sort-by
(lambda (elem)
(thread-last elem
(list)
(org-clock-agg--ungroup)
(mapcar (lambda (row-elem) (alist-get :end row-elem)))
(seq-max)))
#'> nodes))
(defun org-clock-agg--groupby-apply (alist groups elem)
(let* ((group-params (car groups))
(key (nth 0 group-params))
(groupby (nth 1 group-params))
(sort (nth 2 group-params))
(sort-order (nth 3 group-params))
(rest (cdr groups))
(duration (alist-get :duration elem))
(prev-val (alist-get key alist nil nil #'equal)))
(when key
(setf (alist-get key alist nil nil #'equal)
`((:total . ,(+ duration (or (alist-get :total prev-val) 0)))
(:groupby . ,groupby)
(:children . ,(org-clock-agg--groupby-apply
(alist-get :children prev-val) rest elem))
(:sort-symbol . ,sort)
(:sort-order . ,sort-order)
(:elems . ,(if rest
(alist-get :elems prev-val)
(cons elem (alist-get :elems prev-val))))))))
alist)
(defun org-clock-agg--groupby (elems groupby-list sort-list sort-order-list)
(let (res)
(dolist (elem elems)
(let* ((group-symbols (cons 'root-group groupby-list))
(sort-symbols (cons 'total sort-list))
(sort-orders (cons nil sort-order-list))
(groups
(cl-loop for group-symbol in group-symbols
for sort-symbol in sort-symbols
for sort-order in sort-orders
for groupby = (alist-get group-symbol org-clock-agg-groupby)
for group-values = (funcall (alist-get :function groupby) elem)
append
(mapcar
(lambda (group-value)
(list group-value groupby sort-symbol sort-order))
group-values))))
(setq res (org-clock-agg--groupby-apply res groups elem))))
res))
(defun org-clock-agg--ungroup (tree)
(cl-loop for node in tree
append (alist-get :elems node)
append (org-clock-agg--ungroup (alist-get :children node))))
(defun org-clock-agg--groupby-sort (tree)
(let* ((sorted-nodes-by-group
(thread-last
tree
(mapcar (lambda (node) (cons (cons :name (car node)) (cdr node))))
(seq-group-by
(lambda (node)
(list (alist-get :symbol (alist-get :groupby node))
(alist-get :sort-symbol node)
(alist-get :sort-order node))))
(mapcar
(lambda (grouped)
(let ((group-symbol (nth 0 (car grouped)))
(sort-symbol (nth 1 (car grouped)))
(sort-order (nth 2 (car grouped))))
(setf (cdr grouped)
(funcall (thread-last org-clock-agg-sort
(alist-get sort-symbol)
(alist-get :function))
(cdr grouped)))
(when sort-order
(setf (cdr grouped) (reverse (cdr grouped))))
grouped)))
(seq-sort-by
(lambda (grouped)
(thread-last org-clock-agg-groupby
(alist-get (car (car grouped)))
(alist-get :readable-name)))
#'string-lessp)))
(tree (seq-reduce (lambda (acc grouped)
(append (cdr grouped) acc))
sorted-nodes-by-group nil)))
(dolist (node tree)
(let ((children (alist-get :children node))
(elems (alist-get :elems node)))
(when children
(setf (alist-get :children node)
(org-clock-agg--groupby-sort children)))
(when elems
(setf (alist-get :elems node)
(seq-sort-by (lambda (elem) (alist-get :start elem))
#'>
(alist-get :elems node))))))
(mapcar (lambda (node)
(cons (alist-get :name node)
node))
tree)))
;; View & manage results
(defvar-local org-clock-agg--params nil
"Parameters for the current org-clock-agg buffer.")
(defvar-local org-clock-agg--elems nil
"Elements for the current org-clock-agg buffer.")
(defvar-local org-clock-agg--tree nil
"Tree for the current org-clock-agg buffer.")
(defun org-clock-agg-quit ()
(interactive)
(quit-window t))
(defvar org-clock-agg-tree-mode-map
(let ((keymap (make-sparse-keymap)))
(define-key keymap (kbd "q") #'org-clock-agg-quit)
(define-key keymap (kbd "r") #'org-clock-agg-refresh)
(define-key keymap (kbd "<tab>") #'outline-toggle-children)
(when (fboundp 'evil-define-key*)
(evil-define-key* 'normal keymap
"q" #'org-clock-agg-quit
"gr" #'org-clock-agg-refresh
(kbd "<tab>") #'outline-toggle-children))
keymap))
(define-derived-mode org-clock-agg-tree-mode fundamental-mode "Org Clock Agg Tree"
"Major mode for viewing org-clock-agg results."
(outline-minor-mode 1))
(defun org-clock-agg--render-controls-files ()
(apply
#'widget-create 'menu-choice
:tag "Files"
:value (alist-get :files org-clock-agg--params)
:notify (lambda (widget &rest ignore)
(setf (alist-get :files org-clock-agg--params)
(widget-value widget)))
'(item :tag "Org Agenda" :value org-agenda)
(append
(mapcar
(lambda (item)
`(item :tag ,(car item) :value ,(cdr item)))
org-clock-agg-files-preset)
'((editable-list :tag "File"
:entry-format "%i %d %v"
:menu-tag "Custom list"
:value nil
(editable-field :tag "File" :value ""))))))
(defun org-clock-agg--validate-date (widget)
(let ((date (widget-value widget)))
(unless (or (not (stringp date))
(and
(not (string-match-p (rx bos (? "-") (+ digit) eos) date))
(not (and (decoded-time-year val)
(decoded-time-month val)
(decoded-time-day val)))))
(widget-put widget :error "Enter number or date in format YYYY-MM-DD")
widget)))
(defun org-clock-agg--render-controls-date ()
(widget-create 'editable-field
:size 20
:format (concat (propertize "Date from: " 'face 'widget-button) "%v ")
:value (let ((val (alist-get :from org-clock-agg--params)))
(if (numberp val)
(number-to-string val)
val))
:validate #'org-clock-agg--validate-date
:notify (lambda (widget &rest ignore)
(let ((val (widget-value widget)))
(when (string-match-p (rx bos (? "-") (+ digit) eos) val)
(setq val (string-to-number val)))
(setf (alist-get :from org-clock-agg--params) val))))
(widget-create 'editable-field
:size 20
:format (concat (propertize "To: " 'face 'widget-button)
"%v ")
:value (let ((val (alist-get :to org-clock-agg--params)))
(if (numberp val)
(number-to-string val)
val))
:validate #'org-clock-agg--validate-date
:notify (lambda (widget &rest ignore)
(let ((val (widget-value widget)))
(when (string-match-p (rx bos (? "-") (+ digit) eos) val)
(setq val (string-to-number val)))
(setf (alist-get :to org-clock-agg--params) val)))))
(defun org-clock-agg--render-controls-groupby ()
(insert (propertize "Group by: " 'face 'widget-button) "\n")
(widget-create 'editable-list
:tag "Group by"
:entry-format "%i %d %v"
:value (cl-loop for group-value in (alist-get :groupby org-clock-agg--params)
for sort-value in (alist-get :sort org-clock-agg--params)
for sort-order-value in (alist-get :sort-order org-clock-agg--params)
collect (list group-value sort-value sort-order-value))
:notify
(lambda (widget changed-widget &optional event)
(let ((group-value (mapcar #'car (widget-value widget)))
(sort-value (mapcar #'cadr (widget-value widget)))
(sort-order-value (mapcar #'caddr (widget-value widget))))
(setf (alist-get :groupby org-clock-agg--params) group-value)
(setf (alist-get :sort org-clock-agg--params) sort-value)
(setf (alist-get :sort-order org-clock-agg--params) sort-order-value)))
`(group
:value (outline-path total)
(menu-choice
:tag "Group"
:notify (lambda (widget _child &optional event)
(if-let* ((value (widget-value widget))
(default-sort (alist-get
:default-sort
(alist-get value org-clock-agg-groupby)))
(parent (widget-get widget :parent)))
(widget-value-set parent (list value default-sort)))
(widget-default-action widget event))
,@(thread-last
org-clock-agg-groupby
(seq-filter (lambda (groupby)
(not (alist-get :hidden (cdr groupby)))))
(mapcar (lambda (groupby)
(let ((name (car groupby))
(readable-name (alist-get :readable-name (cdr groupby))))
`(item :tag ,readable-name
:value ,name
:menu-tag ,readable-name))))))
(menu-choice
:tag "Order"
,@(mapcar
(lambda (sort)
(let ((name (car sort))
(readable-name (alist-get :readable-name (cdr sort))))
`(item :tag ,readable-name
:value ,name
:menu-tag ,readable-name)))
org-clock-agg-sort))
(toggle :on "Reverse order" :off "Normal order"))))
(defun org-clock-agg--render-switches ()
(insert (propertize "Show elements: " 'face 'widget-button))
(widget-create 'checkbox
:notify (lambda (widget &rest ignore)
(setf (alist-get :show-elems org-clock-agg--params)
(widget-value widget)))
nil)
(insert "\n"))
(defun org-clock-agg--render-controls ()
(remove-overlays)
(insert (propertize "* Parameters" 'face 'org-level-1) "\n")
(org-clock-agg--render-controls-files)
(insert "\n")
(org-clock-agg--render-controls-date)
(insert "\n\n")
(org-clock-agg--render-controls-groupby)
(insert "\n")
(org-clock-agg--render-switches)
(insert "\n")
(widget-create 'push-button
:notify (lambda (&rest ignore)
(org-clock-agg-refresh))
"Refresh")
(insert "\n\n")
(widget-setup))
(defun org-clock-agg--trim-string (string max-len)
(let ((len (length string)))
(if (> len max-len)
(concat (substring string 0 (- max-len 3)) "...")
string)))
(defun org-clock-agg--goto-elem (elem)
(let ((marker (org-element-property :org-marker (alist-get :headline elem))))
(org-goto-marker-or-bmk marker)))
(defun org-clock-agg-render-tree-node-elems (node)
(when-let ((elems (alist-get :elems (cdr node)))
(widget-push-button-prefix "")
(widget-push-button-suffix ""))
(dolist (elem elems)
(let ((elem-name
(format
"- [%s]--[%s] => %s : %s"
(propertize
(thread-last elem
(alist-get :start)
(seconds-to-time)
(format-time-string (cdr org-time-stamp-formats)))
'face 'org-date)
(propertize
(thread-last elem
(alist-get :end)
(seconds-to-time)
(format-time-string (cdr org-time-stamp-formats)))
'face 'org-date)
(org-duration-from-minutes
(/ (alist-get :duration elem) 60))
(concat
(when-let ((todo-keyword (substring-no-properties
(org-element-property
:todo-keyword
(alist-get :headline elem)))))
(propertize
(concat todo-keyword " ") 'face
(if (eq (org-element-property :todo-type (alist-get :headline elem)) 'done)
'org-done 'org-todo)))
(org-element-property :raw-value (alist-get :headline elem))))))
(widget-create 'push-button
:elem elem
:notify (lambda (widget &rest ignore)
(let ((elem (widget-get widget :elem)))
(org-clock-agg--goto-elem elem)))
:button-face 'org-clock-agg-elem-face
elem-name))
(insert "\n"))))
(defun org-clock-agg--render-tree-node (node show-elems &optional level)
(unless level
(setq level 1))
(let ((level-face (nth (mod (1- level) 8) org-level-faces))
(level-string (make-string level ?*))
(title-width (- (window-width) 40)))
(insert
(format (format "%%-%ds %%20s %%8s" title-width)
(propertize (org-clock-agg--trim-string
(concat level-string " " (car node))
title-width)
'face level-face)
(propertize
(alist-get :readable-name (alist-get :groupby (cdr node)))
'face 'org-clock-agg-group-face)
(propertize
(format-seconds
org-clock-agg-duration-format
(alist-get :total (cdr node)))
'face 'org-clock-agg-duration-face))
"\n")
(when show-elems
(org-clock-agg-render-tree-node-elems node)))
(mapc (lambda (child)
(org-clock-agg--render-tree-node child show-elems (1+ level)))
(alist-get :children (cdr node))))
(defun org-clock-agg--parse-files (files)
(cond ((eq files 'org-agenda)
(org-agenda-files))
((member files (mapcar #'car org-clock-agg-files-preset))
(alist-get files org-clock-agg-files-preset nil nil #'equal))
(t files)))
(defun org-clock-agg-refresh ()
(interactive)
(cl-destructuring-bind (&key from to files groupby sort sort-order show-elems)
(cl--alist-to-plist org-clock-agg--params)
(let* ((files (org-clock-agg--parse-files files))
(elems (org-clock-agg--query from to files))
(tree (org-clock-agg--groupby elems groupby sort sort-order))
(tree (org-clock-agg--groupby-sort tree)))
(setq-local org-clock-agg--elems elems)
(setq-local org-clock-agg--tree tree)
(save-excursion
(let ((inhibit-read-only t))
(goto-char (point-min))
(search-forward (format "* Results") nil 'noerror)
(beginning-of-line)
(delete-region (point) (point-max))
(dolist (node tree)
(org-clock-agg--render-tree-node node show-elems)))))))
(defun org-clock-agg (from to files groupby sort sort-order show-elems)
(interactive (list -7 0 'org-agenda nil nil nil nil))
(let* ((buffer (generate-new-buffer "*org-clock-agg*")))
(switch-to-buffer-other-window buffer)
(with-current-buffer buffer
(org-clock-agg-tree-mode)
(setq-local org-clock-agg--params
`((:from . ,from)
(:to . ,to)
(:files . ,files)
(:groupby . ,groupby)
(:sort . ,sort)
(:sort-order . ,sort-order)
(:show-elems . ,show-elems)))
(let ((inhibit-read-only t))
(org-clock-agg--render-controls)
(org-clock-agg-refresh))
(goto-char (point-min)))))
(provide 'org-clock-agg)
;;; org-clock-agg.el ends here