;;; tp-doctest.el --- Executable TP 1.0 examples -*- lexical-binding: t; -*-

;; Copyright (C) 2024-2026 Geekinney
;; SPDX-License-Identifier: GPL-3.0-or-later

;;; Commentary:

;; Executable counterparts of the public examples in README.md and
;; README_CN.md.  Run with `make doctest'.

;;; Code:

(require 'cl-lib)
(require 'tp)

(defvar tp-doctest--failures 0
  "Number of failed TP documentation examples.")

(defvar tp-doctest--total 0
  "Number of executed TP documentation examples.")

(defvar tp-doctest--computed-calls 0
  "Number of explicit computed-value calls in the doctest.")

(defvar tp-doctest--height 7
  "Height returned by the doctest's explicit computed value.")

(defmacro tp-doctest--check (label expected &rest body)
  "Run BODY and compare its value with EXPECTED under LABEL."
  (declare (indent 2) (debug t))
  `(let* ((wanted ,expected)
          (actual
           (condition-case error-data
               (progn ,@body)
             (error (list :unexpected-error error-data)))))
     (cl-incf tp-doctest--total)
     (if (equal actual wanted)
         (princ (format "PASS %s\n" ,label))
       (cl-incf tp-doctest--failures)
       (princ (format "FAIL %s\n  expected: %S\n  actual:   %S\n"
                      ,label wanted actual)))))

(unwind-protect
    (progn
      (tp-doctest--check "static-propertize"
          '("Hello" (:foreground "white" :background "navy") t nil)
        (let* ((callback (lambda (_window _object _position) "Open"))
               (text
                (tp-propertize
                 "Hello"
                 (list 'face '(:foreground "white" :background "navy")
                       'help-echo callback 'keymap nil))))
          (list (substring-no-properties text)
                (get-text-property 0 'face text)
                (eq (get-text-property 0 'help-echo text) callback)
                (get-text-property 0 'keymap text))))

      (tp-doctest--check "buffer-apply"
          '("abcdef" nil italic nil host)
        (with-temp-buffer
          (insert "abcdef")
          (put-text-property 1 7 'category 'host)
          (tp-apply (current-buffer) 2 5 '(face italic))
          (list (buffer-string)
                (get-text-property 1 'face)
                (get-text-property 2 'face)
                (get-text-property 5 'face)
                (get-text-property 3 'category))))

      (tp-doctest--check "declaration-recipe"
          '((:foreground "cyan" :weight bold) "Open item" nil)
        (define-tp tp-doctest-link (foreground)
          `(face (:foreground ,foreground :weight bold)
            help-echo "Open item"
            keymap nil))
        (let ((text (tp-set "item" '(tp-doctest-link "cyan"))))
          (list (get-text-property 0 'face text)
                (get-text-property 0 'help-echo text)
                (get-text-property 0 'keymap text))))

      (tp-doctest--check "explicit-computed-value"
          '(1 (:height 7))
        (setq tp-doctest--computed-calls 0)
        (define-tp tp-doctest-sized ()
          `(face ,(tp-computed
                   (lambda ()
                     (cl-incf tp-doctest--computed-calls)
                     (list :height tp-doctest--height)))))
        (let ((text (tp-set "size" 'tp-doctest-sized)))
          (list tp-doctest--computed-calls
                (get-text-property 0 'face text))))

      (tp-doctest--check "reactive-existing-text"
          '((:foreground "red") (:foreground "green") 2 nil)
        (with-temp-buffer
          (insert "offline")
          (let* ((online (tp-signal-create nil))
                 (surface
                  (tp-watch
                   (current-buffer) 1 8
                   (lambda ()
                     (list 'face
                           (list :foreground
                                 (if (tp-signal-read online)
                                     "green"
                                   "red"))))))
                 (before (get-text-property 1 'face)))
            (tp-signal-set online t)
            (prog1
                (list before
                      (get-text-property 1 'face)
                      (tp-surface-revision surface)
                      (plist-get (tp-surface-unmount surface)
                                 :property-conflicts))
              (tp-signal-dispose online)))))

      (tp-doctest--check "retained-content"
          '("ready" "done" 2 1)
        (with-temp-buffer
          (let* ((status (tp-signal-create "ready"))
                 (producer
                  (lambda (context)
                    (let* ((object
                            (tp-object-ensure context nil 'status 'text))
                           (binding
                            (tp-bind object '(readme . status)
                                     (lambda () (tp-signal-read status)))))
                      (tp-surface-plan-create
                       :key 'status :kind 'text
                       :text (tp-binding-read binding)
                       :props '(face bold) :capability 'content))))
                 (surface
                  (tp-surface-mount
                   (current-buffer) producer '(:capability content)))
                 (first (buffer-string)))
            (tp-with-transaction
              (tp-signal-set status "working")
              (tp-signal-set status "done"))
            (prog1
                (list first (buffer-string)
                      (tp-surface-revision surface)
                      (plist-get (tp-surface-report surface)
                                 :text-operations))
              (tp-surface-unmount surface)
              (tp-signal-dispose status)))))

      (tp-doctest--check "retained-noop"
          '(1 1 nil)
        (with-temp-buffer
          (let* ((plan
                  (tp-surface-plan-create
                   :key 'root :kind 'text :text "same"
                   :capability 'content))
                 (surface
                  (tp-surface-mount
                   (current-buffer) plan '(:capability content)))
                 (revision (tp-surface-revision surface)))
            (set-buffer-modified-p nil)
            (tp-surface-update surface plan)
            (prog1
                (list revision
                      (tp-surface-revision surface)
                      (buffer-modified-p))
              (tp-surface-unmount surface)))))

      (tp-doctest--check "materialize-is-ephemeral"
          '("42" nil nil 0)
        (let ((signal (tp-signal-create 42)) object binding)
          (let ((text
                 (tp-surface-materialize-string
                  (lambda (context)
                    (setq object
                          (tp-object-ensure context nil 'value 'text)
                          binding
                          (tp-bind object '(readme . value)
                                   (lambda () (tp-signal-read signal))))
                    (tp-surface-plan-create
                     :key 'value :kind 'text
                     :text (number-to-string (tp-binding-read binding))
                     :capability 'content)))))
            (prog1
                (list text
                      (tp-object-live-p object)
                      (tp-binding-live-p binding)
                      (tp-signal-subscriber-count signal))
              (tp-signal-dispose signal))))))
  (tp-layer-reset)
  (tp-reactive-reset))

(princ (format "\nTOTAL: %d  FAILURES: %d\n"
               tp-doctest--total tp-doctest--failures))
(when (> tp-doctest--failures 0)
  (kill-emacs 1))

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