;;; org-ql-view-section.el --- Magit-section-like views for Org  -*- lexical-binding: t; -*-

;; Copyright (C) 2019  Adam Porter

;; Author: Adam Porter <adam@alphapapa.net>
;; Keywords:

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

;; Inspired by `magit-section'.

;;; Code:

;;;; Requirements

(require 'eieio)

(require 's)

;;;; Macros

(defmacro org-ql-defkeymap (name copy docstring &rest maps)
  ;; Copied from `defkeymap' in elexandria.el.
  "Define a new keymap variable (using `defvar').

NAME is a symbol, which will be the new variable's symbol.  COPY
may be a keymap which will be copied, or nil, in which case the
new keymap will be sparse.  DOCSTRING is the docstring for
`defvar'.

MAPS is a sequence of alternating key-value pairs.  The keys may
be a string, in which case they will be passed as arguments to
`kbd', or a raw key sequence vector.  The values may be lambdas
or function symbols, as would be normally passed to
`define-key'."
  (declare (indent defun))
  (let* ((map (if copy
                  (copy-keymap copy)
                (make-sparse-keymap (prin1-to-string name)))))
    (cl-loop for (key fn) on maps by #'cddr
             do (progn
                  (when (stringp key)
                    (setq key (kbd key)))
                  (define-key map key fn)))
    `(defvar ,name ',map ,docstring)))

(defmacro org-ql-defclass (name superclasses slots &rest options-and-doc)
  ;; Copied from `defclass*' in elexandria.el.
  ;; MAYBE: Change instance-initform to instance-init.  This would no longer set
  ;; the slot to the value of the expression, but would just evaluate it.  The
  ;; expression could set the slot value with `setq' if necessary.
  "Like `defclass', but supports instance initforms.
Each slot may have an `:instance-initform', which is evaluated in
the context of the object's slots when each instance is
initialized, similar to Python's __init__ method."
  ;; TODO: Add option to set all slots' initforms (e.g. to set them all to nil).
  (declare (indent defun))
  (let* ((slot-inits (-non-nil (--map (let ((name (car it))
                                            (initer (plist-get (cdr it) :instance-initform)))
                                        (when initer
                                          (list 'setq name initer)))
                                      slots)))
         (slot-names (mapcar #'car slots))
         ;; FIXME: `around-fn-name' is unused.
         ;; (around-fn-name (intern (concat (symbol-name name) "-initialize")))
         (docstring (format "Inititalize instance of %s." name)))
    `(progn
       (defclass ,name ,superclasses ,slots ,@options-and-doc)
       (when (> (length ',slot-inits) 0)
         (cl-defmethod initialize-instance :after ((this ,name) &rest _)
           ,docstring
           (with-slots ,slot-names this
             ,@slot-inits))))))

(cl-defmacro org-ql-defstruct (&rest args)
  ;; Copied from `ts-defstruct'.
  "Like `cl-defstruct', but with additional slot options.

Additional slot options and values:

`:accessor-init': a sexp that initializes the slot in the
accessor if the slot is nil.  The symbol `struct' will be bound
to the current struct.  The accessor is defined after the struct
is fully defined, so it may refer to the struct
definition (e.g. by using the `cl-struct' `pcase' macro).

`:aliases': A list of symbols which will be aliased to the slot
accessor, prepended with the struct name (e.g. a struct `ts' with
slot `year' and alias `y' would create an alias `ts-y')."
  (declare (indent defun))
  ;; FIXME: Compiler warnings about accessors defined multiple times.  Not sure if we can fix this
  ;; except by ignoring warnings.
  (let* ((struct-name (car args))
         (struct-slots (cdr args))
         (cl-defstruct-expansion (macroexpand `(cl-defstruct ,struct-name ,@struct-slots)))
         accessor-forms alias-forms)
    (cl-loop for slot in struct-slots
             for pos from 1
             when (listp slot)
             do (-let* (((slot-name _slot-default . slot-options) slot)
                        ((&keys :accessor-init :aliases) slot-options)
                        (accessor-name (intern (concat (symbol-name struct-name) "-" (symbol-name slot-name))))
                        (accessor-docstring (format "Access slot \"%s\" of `%s' struct STRUCT."
                                                    slot-name struct-name))
                        (struct-pred (intern (concat (symbol-name struct-name) "-p")))
                        ;; Accessor form copied from macro expansion of `cl-defstruct'.
                        (accessor-form `(cl-defsubst ,accessor-name (struct)
                                          ,accessor-docstring
                                          ;; FIXME: side-effect-free is probably not true here, but what about error-free?
                                          ;;  (declare (side-effect-free error-free))
                                          (or (,struct-pred struct)
                                              (signal 'wrong-type-argument
                                                      (list ',struct-name struct)))
                                          ,(when accessor-init
                                             `(unless (aref struct ,pos)
                                                (aset struct ,pos ,accessor-init)))
                                          ;; NOTE: It's essential that this `aref' form be last
                                          ;; so the gv-setter works in the compiler macro.
                                          (aref struct ,pos))))
                  (push accessor-form accessor-forms)
                  ;; Remove accessor forms from `cl-defstruct' expansion.  This may be distasteful,
                  ;; but it would seem more distasteful to copy all of `cl-defstruct' and potentially
                  ;; have the implementations diverge in the future when Emacs changes (e.g. the new
                  ;; record type).
                  (cl-loop for form in-ref cl-defstruct-expansion
                           do (pcase form
                                (`(cl-defsubst ,(and accessor (guard (eq accessor accessor-name)))
                                      . ,_)
                                 accessor ; Silence "unused lexical variable" warning.
                                 (setf form nil))))
                  ;; Alias definitions.
                  (cl-loop for alias in aliases
                           for alias-name = (intern (concat (symbol-name struct-name) "-" (symbol-name alias)))
                           do (push `(defalias ',alias-name ',accessor-name) alias-forms))
                  ;; TODO: Setter
                  ;; ,(when (plist-get slot-options :reset)
                  ;;    `(gv-define-setter ,accessor-name (ts value)
                  ;;       `(progn
                  ;;          (aset ,ts ,,pos ,value)
                  ;;          (setf (ts-unix ts) ni))))
                  ))
    `(progn
       ,cl-defstruct-expansion
       ,@accessor-forms
       ,@alias-forms)))

;;;; Variables

(defvar org-ql-view-section-depth -1
  "Depth of current section.
Used in `org-ql-view-string'.")

(org-ql-defkeymap org-ql-view-map nil
  "Map for `org-ql-view' maps."
  [tab] org-ql-view-section-toggle)

;;;; Classes

(org-ql-defclass org-ql-view-section ()
  ;; TODO: Decide/clarify whether beg/end should/can be markers.
  ;; NOTE: Not using initforms for now.
  ((beg :initarg :beg
        :documentation "Position or marker at which section begins in buffer.")
   (end :initarg :end
        :documentation "Position or marker at which section ends in buffer.")
   (header :initarg :header
           :documention "Optional header string.")
   (contents-beg :initarg :contents-beg
                 :documentation "Position or marker at which section's contents begins in buffer (i.e. where the header ends).")
   (items :initarg :items
          :documentation "List of items the section contains.")
   (keymap :initarg :keymap
           :instance-initform org-ql-view-map
           :documentation "Keymap used inside section.")
   (collapsed :initarg :collapsed
              :initform nil
              :documentation "Whether the section is collapsed.")))

;;;; Structs

(org-ql-defstruct org-ql-item
  buffer marker beg category level todo priority heading tags deadline-element scheduled-element properties
  (deadline-ts nil :accessor-init (when-let* ((element (org-ql-item-deadline-element struct)))
                                    (ts-parse-org-element element)))
  (scheduled-ts nil :accessor-init (when-let* ((element (org-ql-item-scheduled-element struct)))
                                     (ts-parse-org-element element))))

;;;; Customization

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

(defcustom org-ql-view-item-indent "  "
  "String used to indent individual items."
  :type 'string)

(defcustom org-ql-view-item-indent-per-level 4
  "Number of spaces used to indent items at each levep."
  :type 'integer)

;;;; Commands

(defun org-ql-view-section-toggle (section)
  "Toggle SECTION, or section at point."
  (interactive (list (org-ql-view-section-at)))
  (when section
    (with-slots (collapsed) section
      (if collapsed
          (org-ql-section-expand section)
        (org-ql-section-collapse section)))))

(defun org-ql-section-collapse (section)
  "Collapse SECTION, or section at point."
  (interactive (list (org-ql-view-section-at)))
  (when section
    (with-slots (collapsed contents-beg end) section
      (setf collapsed t)
      (let ((ov (make-overlay contents-beg end)))
        ;; I don't know if `evaporate' is necessary, but `magit-section' does it.
        (overlay-put ov 'evaporate t)
        (overlay-put ov 'invisible t)))))

(defun org-ql-section-expand (section)
  "Expand SECTION, or section at point."
  (interactive (list (org-ql-view-section-at)))
  (when section
    (with-slots (collapsed contents-beg end) section
      (setf collapsed nil)
      (remove-overlays contents-beg end 'invisible t))))

;;;; Methods

(cl-defmethod org-ql-view-insert ((section org-ql-view-section) &key group-by)
  "Insert SECTION into current buffer."
  (cl-labels ((group (items fns &key parent-header)
                     (setf items (-group-by (car fns) items))
                     (if (cdr fns)
                         (--map (org-ql-view-section
                                 :header (car it)
                                 :items (group (cdr it) (cdr fns) :parent-header (car it)))
                                items)
                       (cond ((assoc nil items)
                              (append (--map (org-ql-view-section
                                              :header (car it)
                                              :items (cdr it))
                                             (butlast items))
                                      (cdr (assoc nil items))))
                             (t (--map (org-ql-view-section
                                        :header (car it)
                                        :items (cdr it))
                                       items))))))
    (with-slots (beg end header contents-beg items keymap) section
      (let* ((org-ql-view-section-depth (1+ org-ql-view-section-depth))
             (org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level
                                                   org-ql-view-section-depth)
                                                " ")))
        (when group-by
          (setf items (group items group-by)))
        (setf beg (point))
        (insert org-ql-view-item-indent (org-ql-view-header section))
        (put-text-property beg (point) :org-ql-view-section section)
        (setf contents-beg (point))
        (let* ((org-ql-view-item-indent (s-repeat (* org-ql-view-item-indent-per-level
                                                     (1+ org-ql-view-section-depth))
                                                  " ")))
          (dolist (item items)
            (insert "\n")
            (cl-typecase item
              (org-ql-view-section (org-ql-view-insert item))
              (list (--each item
                      (insert "\n")
                      (org-ql-view-insert it)))
              (otherwise (org-ql-view-insert item))
              )))
        (setf end (point))
        (put-text-property beg (point) 'keymap keymap)))))

;; (cl-defmethod org-ql-view-insert ((sections list))
;;   "Insert SECTIONS into current buffer."
;;   (let* ((org-ql-view-section-depth (1+ org-ql-view-section-depth)))
;;     (dolist (section sections)
;;       (insert "\n")
;;       (org-ql-view-insert section))))
(cl-defmethod org-ql-view-insert ((sections list))
  "Insert SECTIONS into current buffer."
  (error "OOPS"))

(cl-defmethod org-ql-view-header ((section org-ql-view-section))
  "Return header string for SECTION.
Does not include newline."
  (cl-labels ((num-items (items)
                         (cl-loop for item in items
                                  sum (cl-typecase item
                                        (org-ql-view-section (num-items (oref item items)))
                                        (list (cl-loop for section in item
                                                       sum (num-items (oref section items))))
                                        (otherwise 1)))))
    (with-slots (header items) section
      (concat (propertize (format "%s"
                                  (or header "None"))
                          'face 'magit-section-heading)
              " (" (number-to-string (num-items items)) ")"))))

(cl-defmethod org-ql-view-insert ((item org-ql-item))
  "Insert ITEM into current buffer.
Does not insert newline."
  (pcase-let* (((cl-struct org-ql-item todo priority heading tags) item)
               (beg (point)))
    (insert org-ql-view-item-indent)
    (when todo
      (insert (propertize todo 'face (org-get-todo-face todo)) " "))
    (when priority
      (insert (propertize (concat "[#" priority "]") 'face (org-get-priority-face priority)) " "))
    (when heading
      (insert heading " "))
    (when tags
      (insert (propertize (s-join ":" tags) 'face 'org-tag-group)))
    (put-text-property beg (point) :org-ql-view-section item)))

(cl-defmethod org-ql-view-insert ((item string))
  "Insert ITEM into current buffer."
  (insert item))

;;;; Functions

(cl-defun org-ql-view-section-at (&optional (pos (point-at-bol)))
  (get-text-property pos :org-ql-view-section))

(defun org-ql-item-at ()
  ;; FIXME: Put this function elsewhere.
  "Return `org-ql-item' for entry at point."
  (-let* (((_ (&plist :begin :level :raw-value :priority :tags :todo-keyword :deadline :scheduled :CATEGORY))
           (org-element-headline-parser (line-end-position))))
    (make-org-ql-item :beg begin
                      :category CATEGORY
                      :level level
                      :todo todo-keyword
                      :priority (when priority
                                  (char-to-string priority))
                      :heading raw-value
                      :tags tags
                      :deadline-element deadline
                      :scheduled-element scheduled)))

(defun org-ql-view-sort-todo (items)
  "Return ITEMS sorted by to-do keyword, in to-do keyword order.
Uses `org-todo-keywords', which does not include buffer-local
keywords."
  (cl-flet ((keyword (string)
                     ;; Return keyword without parenthesized options.
                     (unless (string= string "|")
                       (if (string-match (rx (group (minimal-match (1+ anything)))
                                             "(" (1+ anything) ")")
                                         string)
                           (match-string 1 string)
                         string))))
    (let ((keywords (cl-loop with non-done-keywords with done-keywords
                             for (_type . keywords) in (reverse org-todo-keywords)
                             for non-done = (->> keywords
                                                 (--take-while (not (string= it "|")))
                                                 (-map #'keyword))
                             for done = (-map #'keyword
                                              (-slice keywords
                                                      (1+ (or (--find-index (string= it "|")
                                                                            keywords)
                                                              -1))))
                             do (progn
                                  (setf non-done-keywords (append non-done non-done-keywords))
                                  (setf done-keywords (append done done-keywords)))
                             finally return (append non-done-keywords done-keywords))))
      (-sort (lambda (a b)
               (cond ((and (org-ql-item-todo a)
                           (org-ql-item-todo b))
                      (< (or (cl-position (org-ql-item-todo a) keywords :test #'string=) 0)
                         (or (cl-position (org-ql-item-todo b) keywords :test #'string=) 0)))
                     ((org-ql-item-todo a) t)
                     ((org-ql-item-todo b) nil)))
             items))))


(defun org-ql-view-sort-planning (items)
  "Return ITEMS sorted by planning date."
  (cl-flet ((planning-ts (item)
                         (or (org-ql-item-deadline-ts item) (org-ql-item-scheduled-ts item))))
    (sort items (lambda (a b)
                  (let ((a-ts (planning-ts a))
                        (b-ts (planning-ts b)))
                    (cond ((and a-ts b-ts)
                           (ts< a-ts b-ts))
                          (a-ts t)
                          (b-ts nil)))))))

;;;; Footer

(provide 'org-ql-view-section)

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