;;; tp.el ---  Utilities for transient menus that POST to an API -*- lexical-binding: t; -*-

;; Author: Marty Hiatt <mousebot@disroot.org>
;; Copyright (C) 2024 Marty Hiatt <mousebot@disroot.org>
;; Version: 0.8
;; Package-Requires: ((emacs "28.1") (transient "0.5.0"))
;; Keywords: convenience, api, requests
;; URL: https://codeberg.org/martianh/tp.el

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

;; Some functions, classes and methods to make it easier to create
;; transient menus that send complex POST, PUT, or PATCH requests to JSON
;; APIs.

;; A typical use-case is where you have a single endpoint that takes many
;; different parameters. It's handy for a user to be able to set all the
;; options, then make a single request to change all the settings on the
;; server. It's also expected that they'll be able to view all the current
;; settings on the server, and make modifications to them for sending.

;; The classes and methods define some transient behaviours that make
;; sense for dealing with APIs:

;; - We handle fetching and saving current server settings, and initialize
;; our transients with the values fetched
;; - We compare the state of a current transient option against the server
;; values
;; - We distinguish the formatting of server settings and current transient
;; setting
;; - When reading a string from the user, we provide the server setting as
;; default input
;; - We can seemlessly handle making requests with arrays, i.e. =source[key]=,
;; or =field[1][name]= parameters
;; - We can easily fetch an infix's allowed values for =completing-read=
;; - We (ususally) only send changed values to the server.


;;; Code:

(require 'transient)
(require 'json)

;;; VARIABLES

(defvar tp-choice-booleans '("true" "false")
  "Boolean strings for sending non-JSON requests.")

(defvar tp-transient-settings nil
  "Settings for the current transient prefix.
This can hold either the default settings data (editable) as
returned by a server, or alternatively the transient's current
settings if it is only stored when completed, and may be edited
again before being sent.")

;;; UTILS

(defun tp-remove-not-editable (alist var)
  "Remove non-editable fields from ALIST.
Check against the fields in VAR, which should be a list of strings."
  (cl-remove-if-not
   (lambda (x)
     (member (symbol-name (car x))
             var))
   alist))

(defun tp-return-data (fetch-fun &optional editable-var field)
  "Return data to populate current settings.
Call FETCH-FUN with zero arguments to GET the data. Cull the data
with `tp-remove-not-editable', bind the result to
`tp-transient-settings' and return it.
EDITABLE-VAR is a variable containing a list of strings
corresponding to the editable fields of the JSON data returned.
See `tp-remove-not-editable'.
FIELD is a JSON field to set `tp-transient-settings' to, fetched
with `alist-get'."
  (let* ((data (funcall fetch-fun))
         (editable (if editable-var
                       (tp-remove-not-editable data editable-var)
                     data)))
    (setq tp-transient-settings
          (if field
              (alist-get field editable)
            editable))))

(defun tp-only-changed-args (alist)
  "Remove elts from ALIST if value is changed.
Values are considered changed if they do not match those in
`tp-transient-settings'. Nil values are also removed if they
match the empty string.
If ALIST contains dotted.notation keys, we drill down into
`tp-transient-settings' to check the value."
  (prog1
      (cl-remove-if
       (lambda (x)
         (let* ((split (split-string (symbol-name (car x)) "\\."))
                (server-val
                 (if (< 1 (length split))
                     ;; FIXME: handle arbitrary nesting:
                     (alist-get (intern (cadr split))
                                (alist-get (intern (car split))
                                           tp-transient-settings))
                   (alist-get (car x)
                              tp-transient-settings))))
           (cond ((not (cdr x)) (equal "" server-val))
                 (t (equal (cdr x) server-val)))))
       alist)
    ;; unset our vars (comment if need to inspect):
    (setq tp-transient-settings nil)))

(defun tp-bool-to-str (cons)
  "Convert CONS, into a string boolean if it is either t or :json-false.
Otherwise just return CONS."
  (if (not (consp cons))
      cons
    (cons (car cons)
          (cond ((eq :json-false (cdr cons)) "false")
                ((eq t (cdr cons)) "true")
                (t (cdr cons))))))

(defun tp-bool-str-to-json (cons)
  "Convert CONS, into a string boolean if it is either t or :json-false.
Otherwise just return CONS."
  ;; do nothing if not a cons: `-tree-map' doesn't handle parsed JSON well
  (if (not (consp cons))
      cons
    (cons (car cons)
          (cond ((equal "false" (cdr cons)) :json-false)
                ((equal "true" (cdr cons)) t)
                (t (cdr cons))))))

(defun tp-tree-map (fn tree)
  "Apply FN to each element of TREE while preserving the tree structure.
This is just `-tree-map' from the dash library."
  ;; (declare (important-return-value t)) ;; commented for older emacsen
  (cond
   ((null tree) ())
   ;; the smallest element this operates on is not a list item, but a cons
   ;; pair, e.g. (a . b):
   ((nlistp (cdr-safe tree)) ;; ie `-cons-pair?'
    (funcall fn tree))
   ((consp tree)
    (mapcar (lambda (x) (tp-tree-map fn x)) tree))
   ((funcall fn tree))))

(defun tp-bools-to-strs (alist)
  "Convert values in ALIST to string booleans if they are JSON booleans."
  (tp-tree-map
   #'tp-bool-to-str alist))

(defun tp-bool-strs-to-json (alist)
  "Convert values in ALIST to string booleans if they are JSON booleans."
  (tp-tree-map
   #'tp-bool-str-to-json alist))

(defun tp-dots-to-arrays (alist &optional only-last-two parent-suffix)
  "Convert keys in ALIST tp dot annotation to array[key] annotation.
If ONLY-LAST-TWO is non-nil, return only secondlast[last] from
KEY.
PARENT-SUFFIX is appended to the first element."
  ;; FIXME: handle multi dots?
  (cl-loop for a in alist
           collect (cons (tp-dot-to-array (symbol-name (car a))
                                          only-last-two parent-suffix)
                         (cdr a))))

(defun tp-dot-to-array (key &optional only-last-two parent-suffix)
  "Convert KEY from tp dot annotation to array[key] annotation.
Handles multiple values by calling `tp-dot-to-array-multi', which
see.
If ONLY-LAST-TWO is non-nil, return only secondlast[last] from
KEY.
PARENT-SUFFIX is appended to the first element."
  (let* ((split (split-string key "\\.")))
    (cond ((not key) nil)
          ((= 1 (length split)) key)
          (only-last-two
           (concat ;; but last item
            (car (last split 2))
            ;; last item
            "[" (car (last split)) "]"))
          (t (tp-dot-to-array-multi split parent-suffix)))))

(defun tp-dot-to-array-multi (list parent-suffix)
  "Wrap all elements of LIST in [square][brackets] save the first.
Concatenate the results together.
PARENT-SUFFIX is appended to the first element."
  (mapconcat
   (lambda (x)
     (if (equal x (car list))
         (if parent-suffix
             (concat x parent-suffix)
           x)
       (concat"[" x "]")))
   list))

(defun tp--get-choices (obj)
  "Return the value contained in OBJ's choices-slot.
It might be a symbol, in which case evaluate it, a function, in
which case call it. else just return it."
  (let ((slot (oref obj choices)))
    (cond ((functionp slot)
           (funcall slot))
          ((symbolp slot)
           (symbol-value slot))
          (t slot))))

(defun tp-parse-args-for-send (args &optional strings)
  "Parse ARGS, an alist of args for sending.
If STRINGS is non-nil, convert elisp JSON booleans into string
booleans."
  (let* ((changed (tp-only-changed-args args))
         (arrays (tp-dots-to-arrays changed)))
    (if strings
        (tp-bools-to-strs arrays)
      arrays)))

;; CLASSES

(defclass tp-option (transient-option)
  ((always-read :initarg :always-read :initform t)
   (alist-key :initarg :alist-key)) ;; :key slot already taken!
  "An infix option class for our options.
We always read.")

(defclass tp-option-str (tp-option)
  ((format :initform " %k %d %v"))
  "An infix option class for our option strings.
We always read, and our reader provides initial input from
default/current values.")

(defclass tp-bool (tp-option)
  ((format :initform " %k %d %v")
   (choices :initarg :choices :initform
            (lambda () tp-choice-booleans)))
  "An option class for our choice booleans.
We implement this as an option because we need to be able to
explicitly send true/false values to the server, whereas
transient ignores false/nil values.")

(defclass tp-cycle (tp-bool)
  ()
  "A class to cycle through options.
Like `tp-bool', but supports arbitrary multiple options.
Values to send will not be JSON booleans, but plain strings.")

;;; TRANSIENT METHODS
;; for `tp-bool' we define our own infix option that displays
;; [true|false] like exclusive switches. activating the infix
;; moves to the next option.

(cl-defmethod transient-infix-value ((obj tp-option))
  "Return the infix value of OBJ as a cons cell."
  (cons (oref obj alist-key)
        (oref obj value)))

(cl-defmethod transient-init-value ((obj tp-option))
  "Initialize the value of OBJ."
  (let* ((prefix-val
          ;; (transient-get-value))) ;; new transient (broken)
          ;; (transient--get-extended-value))) (also broken)
          ;; (oref transient--prefix value))) ;; old transient (broken)
          ;; (transient-scope))) ;; doesn't work
          tp-transient-settings)) ;; our variable (works?)
    (oset obj value
          (tp-get-server-val obj prefix-val))))

(cl-defmethod transient-format-value ((obj tp-option))
  "Format the value of OBJ.
Format should just be a string, highlighted green if it has been
changed from the server value."
  (let* ((cons (transient-infix-value obj))
         (value (when cons (cdr cons))))
    (if (not value)
        ""
      (propertize value
                  'face (if (tp-arg-changed-p obj cons)
                            'transient-value
                          'transient-inactive-value)))))

(defvar tp-json-bool-alist
  '((t . "true")
    (:json-false . "false"))
  "An alist for JSON booleans and boolean strings.")

(defun tp-get-bool-str (bool)
  "Given a JSON BOOL, return its string boolean."
  (alist-get bool tp-json-bool-alist))

(defun tp-active-face-maybe (obj cons)
  "Return a face spec based on OBJ's value and CONS."
  (let* ((value (oref obj value))
         (active-p (equal (cdr cons)
                          (if (symbolp value)
                              (tp-get-bool-str value)
                            value)))
         (changed-p (tp-arg-changed-p obj cons)))
    ;; FIXME: differentiate init server value
    ;; from switching to other value then switching
    ;; back to server value?
    (cond ((and active-p changed-p)
           'transient-value)
          ((and active-p (not changed-p))
           '(:inherit transient-value :underline t))
          ((and (not active-p) (not changed-p))
           '(:inherit transient-inactive-value :underline t))
          (t
           'transient-inactive-value))))

(cl-defmethod transient-format-value ((obj tp-bool))
  "Format the value of OBJ.
Format should be like \"[opt1|op2]\", with the active option highlighted.
The value currently on the server should be underlined."
  (let* ((key (oref obj alist-key))
         (choices (tp--get-choices obj)))
    (concat
     (propertize "["
                 'face 'transient-inactive-value)
     (mapconcat
      (lambda (choice)
        (let ((cons (cons key choice)))
          (propertize
           choice
           'face (tp-active-face-maybe obj cons))))
      choices
      (propertize "|" 'face 'transient-inactive-value))
     (propertize "]" 'face 'transient-inactive-value))))

(cl-defmethod transient-infix-read ((obj tp-bool))
  "Cycle through the possible values of OBJ."
  (let* ((cons (transient-infix-value obj))
         (val (tp-get-bool-str (cdr cons)))
         (choices (tp--get-choices obj))
         (str (if (or (not val) ;; handle nil value
                      (equal val (car (last choices))))
                  (car choices)
                (cadr (member val choices)))))
    ;; return JSON bool:
    (car (rassoc str tp-json-bool-alist))))

(cl-defmethod transient-infix-read ((obj tp-cycle))
  "Cycle through the possible values of OBJ."
  (let* ((cons (transient-infix-value obj))
         (val (cdr cons))
         (choices (tp--get-choices obj)))
    (if (or (not val) ;; handle nil value
            (equal val (car (last choices))))
        (car choices)
      (cadr (member val choices)))))

;; FIXME: see the `transient-infix-read' method's docstring:
;; we should preserve history, follow it. maybe just mod it.
(cl-defmethod transient-infix-read ((obj tp-option-str))
  "Reader function for OBJ.
We add the current value as initial input."
  (let* ((value (transient-infix-value obj))
         (prompt (transient-prompt obj)))
    (read-string prompt (cdr value))))

(cl-defmethod transient-prompt ((obj tp-option))
  "Format a prompt for OBJ."
  (let* ((key (oref obj alist-key))
         (split (split-string (symbol-name key) "\\."))
         (str (string-replace "_" " " (car (last split)))))
    (format "%s: " str)))

(cl-defmethod transient-infix-read ((obj tp-option))
  "Cycle through the possible values of OBJ."
  (let* ((prompt (transient-prompt obj))
         (choices (tp--get-choices obj)))
    (completing-read prompt choices nil :match)))

;;; OUR METHODS

(cl-defmethod tp-arg-changed-p ((obj tp-option) cons)
  "T if value of CONS is different to the value in `tp-transient-settings'.
The format of the value is a transient pair as a string, ie \"key=val\".
Nil values will also match the empty string.
OBJ is the object whose args are being checked."
  (let* ((data ;; (transient-get-value)) ;; new transient (broken)
          ;; (oref transient--prefix value)) ;; get from prefix (old, broken)
          ;; get from self? (works if suffix initialized, but useless, as
          ;; we need no just val but also key to check server val):
          ;; (oref obj value))
          ;; our variable (works, server value rather than current prefix
          ;; state):
          tp-transient-settings)
         (server-val (tp-get-server-val obj data))
         (server-str (if (and server-val
                              (symbolp server-val))
                         (tp-get-bool-str server-val)
                       server-val)))
    (not (equal (cdr cons) server-str))))

(cl-defmethod tp-get-server-val ((obj tp-option) data)
  "Return the server value for OBJ from DATA.
If OBJ's key has dotted notation, drill down into the alist. Currently
only one level of nesting is supported.
DATA is JSON data returned from the server."
  ;; TODO: handle nested alist keys
  (let* ((key (oref obj alist-key))
         (split (split-string (symbol-name key) "\\.")))
    (cond ((= 1 (length split))
           (alist-get key data))
          ((= 2 (length split))
           (alist-get (intern (cadr split))
                      (alist-get (intern (car split)) data))))))

;;; VARIABLE CLASS

;; a class used to implement `transient-init-value' in a way that doesn't
;; fetch from a server, but merely gets data from `tp-transient-settings'.
;; this hopefully means you can multi-inherit from this class and another,
;; and not have to implement `transient-init-value' for each of your
;; class(es).

;; it seems like for this to work right, tp-option-var should be the
;; second, not first, superclass. e.g. (defclass your-tp-option (tp-option
;; tp-option-var) (()))

(defclass tp-option-var (tp-option)
  (()))

(cl-defmethod transient-init-value ((obj tp-option-var))
  "Initialize OBJ, an option.
Pull value from `tp-transient-settings' if possible.'"
  (let ((key (oref obj alist-key)))
    (oset obj value
          (alist-get key tp-transient-settings))))

(provide 'tp)
;;; tp.el ends here