;;; etaf-performance.el --- Optional ETAF operation recorder -*- lexical-binding: t; -*-

;; SPDX-License-Identifier: GPL-3.0-or-later

;;; Commentary:

;; This optional package records the flat provider reports emitted by one
;; mounted ETAF Runtime.  It has no advice registry and owns no timing path:
;; operation boundaries and durations come exclusively from the Runtime
;; observer contract.

;;; Code:

(require 'cl-lib)
(require 'pp)
(require 'ring)
(require 'seq)
(require 'tabulated-list)
(require 'etaf-runtime)

(defgroup etaf-performance nil
  "Operation timing reports emitted by ETAF runtimes."
  :group 'etaf)

(defcustom etaf-performance-max-records 200
  "Maximum completed operations retained by the recorder."
  :type 'integer
  :group 'etaf-performance)

(defconst etaf-performance-report-format-version 2
  "Current portable performance report format version.")

(cl-defstruct (etaf-performance-stage
               (:constructor etaf-performance--stage-create))
  "One flat provider report belonging to an operation."
  sequence provider category name duration status metadata)

(cl-defstruct (etaf-performance-operation
               (:constructor etaf-performance--operation-create))
  "One completed Runtime operation and its ordered provider reports."
  id kind label runtime-id buffer-name generation-before generation-after
  elapsed status gc-count gc-elapsed metadata stages)

(cl-defstruct (etaf-performance--attachment
               (:constructor etaf-performance--attachment-create))
  sink pending-keys)

(defvar etaf-performance--record-ring nil)
(defvar etaf-performance--pending (make-hash-table :test #'equal))
(defvar etaf-performance--attachments (make-hash-table :test #'eq))
(defvar-local etaf-performance--mode-runtime nil)

(defconst etaf-performance--report-context-keys
  '(:format-version :operation-id :sequence :runtime-id :buffer-name
    :provider :stage :status :duration-ms)
  "Flat report keys represented by typed recorder fields.")

(defun etaf-performance--copy-value (value)
  "Return a defensive recorder snapshot of VALUE."
  (cond
   ((stringp value) (copy-sequence value))
   ((consp value)
    (cons (etaf-performance--copy-value (car value))
          (etaf-performance--copy-value (cdr value))))
   ((vectorp value)
    (apply #'vector
           (mapcar #'etaf-performance--copy-value (append value nil))))
   ((hash-table-p value)
    (let ((copy (copy-hash-table value)))
      (clrhash copy)
      (maphash (lambda (key item)
                 (puthash (etaf-performance--copy-value key)
                          (etaf-performance--copy-value item)
                          copy))
               value)
      copy))
   (t value)))

(defun etaf-performance--copy-stage (stage)
  "Return an isolated snapshot of recorder STAGE."
  (etaf-performance--stage-create
   :sequence (etaf-performance-stage-sequence stage)
   :provider (etaf-performance-stage-provider stage)
   :category (etaf-performance-stage-category stage)
   :name (etaf-performance-stage-name stage)
   :duration (etaf-performance-stage-duration stage)
   :status (etaf-performance-stage-status stage)
   :metadata
   (etaf-performance--copy-value (etaf-performance-stage-metadata stage))))

(defun etaf-performance--copy-operation (operation)
  "Return an isolated snapshot of recorder OPERATION."
  (etaf-performance--operation-create
   :id (etaf-performance-operation-id operation)
   :kind (etaf-performance-operation-kind operation)
   :label (etaf-performance--copy-value
           (etaf-performance-operation-label operation))
   :runtime-id (etaf-performance-operation-runtime-id operation)
   :buffer-name (etaf-performance--copy-value
                 (etaf-performance-operation-buffer-name operation))
   :generation-before
   (etaf-performance-operation-generation-before operation)
   :generation-after
   (etaf-performance-operation-generation-after operation)
   :elapsed (etaf-performance-operation-elapsed operation)
   :status (etaf-performance-operation-status operation)
   :gc-count (etaf-performance-operation-gc-count operation)
   :gc-elapsed (etaf-performance-operation-gc-elapsed operation)
   :metadata
   (etaf-performance--copy-value
    (etaf-performance-operation-metadata operation))
   :stages (mapcar #'etaf-performance--copy-stage
                   (etaf-performance-operation-stages operation))))

(defun etaf-performance-records (&optional runtime-id)
  "Return newest-first immutable snapshots of completed records.
When RUNTIME-ID is non-nil, select only that integer observer report identity,
as exposed by `etaf-performance-operation-runtime-id'.  This also selects
historical records after unmount or reuse of a buffer name.  Omitted or nil
RUNTIME-ID selects all retained records."
  (unless (or (null runtime-id) (integerp runtime-id))
    (signal 'wrong-type-argument (list 'integerp runtime-id)))
  (let ((records (and etaf-performance--record-ring
                      (ring-elements etaf-performance--record-ring))))
    (mapcar #'etaf-performance--copy-operation
            (if runtime-id
                (seq-filter
                 (lambda (operation)
                   (equal runtime-id
                          (etaf-performance-operation-runtime-id operation)))
                 records)
              records))))

(defun etaf-performance--percentile (samples percentile)
  "Return nearest-rank PERCENTILE from numeric SAMPLES."
  (when samples
    (let* ((ordered (sort (copy-sequence samples) #'<))
           (rank (max 1 (ceiling (* percentile (length ordered))))))
      (nth (1- rank) ordered))))

(defun etaf-performance--provider-category (provider)
  "Return the public recorder category for PROVIDER."
  (if (eq provider 'etaf) 'runtime provider))

(defun etaf-performance--report-metadata (report)
  "Return REPORT fields not represented by typed recorder fields."
  (let (metadata)
    (while report
      (let ((key (pop report))
            (value (pop report)))
        (unless (memq key etaf-performance--report-context-keys)
          (setq metadata
                (append metadata
                        (list key (etaf-performance--copy-value value)))))))
    metadata))

(defun etaf-performance--stage-from-report (report)
  "Create one flat recorder stage from provider REPORT."
  (let ((provider (plist-get report :provider)))
    (etaf-performance--stage-create
     :sequence (plist-get report :sequence)
     :provider provider
     :category (etaf-performance--provider-category provider)
     :name (plist-get report :stage)
     :duration (plist-get report :duration-ms)
     :status (plist-get report :status)
     :metadata (etaf-performance--report-metadata report))))

(defun etaf-performance-operation-stage-summary (operation)
  "Summarize flat provider stages in OPERATION by category.

Each result contains `:category', `:count', and `:duration-ms'.  Provider
durations may overlap and are therefore never presented as exclusive time."
  (unless (etaf-performance-operation-p operation)
    (signal 'wrong-type-argument
            (list 'etaf-performance-operation-p operation)))
  (let ((table (make-hash-table :test #'eq)) result)
    (dolist (stage (etaf-performance-operation-stages operation))
      (let* ((category (etaf-performance-stage-category stage))
             (entry (or (gethash category table) (cons 0 0.0))))
        (setcar entry (1+ (car entry)))
        (setcdr entry (+ (cdr entry)
                         (etaf-performance-stage-duration stage)))
        (puthash category entry table)))
    (maphash
     (lambda (category entry)
       (push (list :category category :count (car entry)
                   :duration-ms (cdr entry))
             result))
     table)
    (sort result (lambda (left right)
                   (> (plist-get left :duration-ms)
                      (plist-get right :duration-ms))))))

(cl-defun etaf-performance-summary
    (&optional (records (etaf-performance-records)))
  "Summarize completed RECORDS by operation kind and label.
Omitted RECORDS selects all retained records; explicit nil selects none."
  (let ((groups (make-hash-table :test #'equal)) result)
    (dolist (operation records)
      (let ((key (cons (etaf-performance-operation-kind operation)
                       (etaf-performance-operation-label operation))))
        (puthash key
                 (cons (etaf-performance-operation-elapsed operation)
                       (gethash key groups))
                 groups)))
    (maphash
     (lambda (key samples)
       (push
        (list :kind (car key) :label (cdr key) :count (length samples)
              :min-ms (apply #'min samples)
              :p50-ms (etaf-performance--percentile samples 0.50)
              :p95-ms (etaf-performance--percentile samples 0.95)
              :max-ms (apply #'max samples)
              :mean-ms (/ (apply #'+ samples) (float (length samples))))
        result))
     groups)
    (sort result (lambda (left right)
                   (> (plist-get left :p95-ms)
                      (plist-get right :p95-ms))))))

(defun etaf-performance--retain (operation)
  "Retain completed OPERATION under the configured bound."
  (let ((limit (max 0 etaf-performance-max-records)))
    (if (zerop limit)
        (setq etaf-performance--record-ring nil)
      (unless (and etaf-performance--record-ring
                   (= (ring-size etaf-performance--record-ring) limit))
        (let ((existing (etaf-performance-records)))
          (setq etaf-performance--record-ring (make-ring limit))
          (dolist (record (reverse (seq-take existing limit)))
            (ring-insert etaf-performance--record-ring record))))
      (ring-insert etaf-performance--record-ring operation))))

(defun etaf-performance--final-report-p (report)
  "Return non-nil when REPORT closes one Runtime operation."
  (and (eq (plist-get report :provider) 'etaf)
       (eq (plist-get report :stage) 'runtime-operation)))

(defun etaf-performance--operation-from-reports (reports)
  "Create one completed operation from ordered flat REPORTS."
  (let* ((ordered
          (sort reports
                (lambda (left right)
                  (< (plist-get left :sequence)
                     (plist-get right :sequence)))))
         (final (car (last ordered))))
    (etaf-performance--operation-create
     :id (plist-get final :operation-id)
     :kind (plist-get final :kind)
     :label (plist-get final :label)
     :runtime-id (plist-get final :runtime-id)
     :buffer-name (plist-get final :buffer-name)
     :generation-before (plist-get final :generation-before)
     :generation-after (plist-get final :generation-after)
     :elapsed (plist-get final :duration-ms)
     :status (plist-get final :status)
     :gc-count (or (plist-get final :gc-count) 0)
     :gc-elapsed (or (plist-get final :gc-duration-ms) 0.0)
     :metadata (etaf-performance--report-metadata final)
     :stages (mapcar #'etaf-performance--stage-from-report ordered))))

(defun etaf-performance--pending-key (report)
  "Return the Runtime and operation correlation key for REPORT."
  (cons (plist-get report :runtime-id)
        (plist-get report :operation-id)))

(defun etaf-performance--capture (runtime report)
  "Capture one flat REPORT emitted by RUNTIME."
  (let* ((attachment (gethash runtime etaf-performance--attachments))
         (key (etaf-performance--pending-key report))
         (reports (cons (copy-tree report)
                        (gethash key etaf-performance--pending))))
    (when attachment
      (cl-pushnew key (etaf-performance--attachment-pending-keys attachment)
                  :test #'equal))
    (if (etaf-performance--final-report-p report)
        (progn
          (remhash key etaf-performance--pending)
          (when attachment
            (setf (etaf-performance--attachment-pending-keys attachment)
                  (delete key
                          (etaf-performance--attachment-pending-keys
                           attachment))))
          (etaf-performance--retain
           (etaf-performance--operation-from-reports reports))
          (when (eq (plist-get report :kind) 'unmount)
            (remhash runtime etaf-performance--attachments)))
      (puthash key reports etaf-performance--pending)))
  nil)

(defun etaf-performance--discard-pending (attachment)
  "Discard unfinished records owned by ATTACHMENT."
  (dolist (key (etaf-performance--attachment-pending-keys attachment))
    (remhash key etaf-performance--pending))
  (setf (etaf-performance--attachment-pending-keys attachment) nil))

;;;###autoload
(defun etaf-performance-start (runtime)
  "Attach the recorder to mounted RUNTIME and return RUNTIME.

Attachment is idempotent for this recorder.  A Runtime already owned by a
  different observer is rejected rather than replaced."
  (setq runtime (etaf-runtime-require-mounted runtime))
  (let* ((attachment (gethash runtime etaf-performance--attachments))
         (owned-sink (and attachment
                          (etaf-performance--attachment-sink attachment))))
    (cond
     (owned-sink
      (unless (etaf-runtime-compare-and-set-observer
               runtime owned-sink owned-sink)
        (error "ETAF recorder no longer owns the Runtime observer"))
      runtime)
     (t
      (when attachment
        (remhash runtime etaf-performance--attachments))
      (let* ((sink (lambda (report)
                     (etaf-performance--capture runtime report)))
             (new (etaf-performance--attachment-create
                   :sink sink :pending-keys nil)))
        (unless (etaf-runtime-compare-and-set-observer runtime nil sink)
          (error "ETAF runtime already has a different observer"))
        (puthash runtime new etaf-performance--attachments)
        runtime)))))

;;;###autoload
(defun etaf-performance-stop (runtime)
  "Detach this recorder from RUNTIME and return RUNTIME.

If another observer replaced the recorder sink, leave that observer intact."
  (unless (etaf-runtime-p runtime)
    (signal 'wrong-type-argument (list 'etaf-runtime-p runtime)))
  (when-let* ((attachment
               (gethash runtime etaf-performance--attachments)))
    (let ((sink (etaf-performance--attachment-sink attachment)))
      (condition-case nil
          (etaf-runtime-compare-and-set-observer runtime sink nil)
        (etaf-runtime-error nil)))
    (etaf-performance--discard-pending attachment)
    (remhash runtime etaf-performance--attachments))
  runtime)

;;;###autoload
(defun etaf-performance-call-operation (runtime kind label function)
  "Call FUNCTION as KIND and LABEL through RUNTIME's operation boundary."
  (etaf-runtime-call-operation runtime kind label function))

(cl-defmacro etaf-performance-with-operation
    ((runtime kind label) &rest body)
  "Evaluate BODY through RUNTIME's canonical operation boundary."
  (declare (indent 1) (debug ((form form form) body)))
  `(etaf-performance-call-operation
    ,runtime ,kind ,label (lambda () ,@body)))

;;;###autoload
(define-minor-mode etaf-performance-mode
  "Record operations for the Runtime mounted in the current buffer."
  :init-value nil
  :lighter " ETAF-Perf"
  (if etaf-performance-mode
      (let ((runtime (etaf-runtime-for-buffer (current-buffer))))
        (unless runtime
          (setq etaf-performance-mode nil)
          (user-error "Current buffer has no mounted ETAF runtime"))
        (condition-case condition
            (progn
              (etaf-performance-start runtime)
              (setq etaf-performance--mode-runtime runtime))
          (error
           (setq etaf-performance-mode nil)
           (signal (car condition) (cdr condition)))))
    (when etaf-performance--mode-runtime
      (etaf-performance-stop etaf-performance--mode-runtime)
      (setq etaf-performance--mode-runtime nil))))

;;;###autoload
(defun etaf-performance-clear ()
  "Clear completed and unfinished performance records."
  (interactive)
  (setq etaf-performance--record-ring nil)
  (clrhash etaf-performance--pending)
  (when-let* ((panel (get-buffer "*ETAF Performance*")))
    (with-current-buffer panel
      (when (derived-mode-p 'etaf-performance-panel-mode)
        (tabulated-list-revert))))
  nil)

(defun etaf-performance--stage-report-data (stage)
  "Return portable report data for STAGE."
  (list :sequence (etaf-performance-stage-sequence stage)
        :provider (etaf-performance-stage-provider stage)
        :category (etaf-performance-stage-category stage)
        :stage (etaf-performance-stage-name stage)
        :duration-ms (etaf-performance-stage-duration stage)
        :status (etaf-performance-stage-status stage)
        :metadata
        (etaf-performance--copy-value
         (etaf-performance-stage-metadata stage))))

(defun etaf-performance--operation-report-data (operation)
  "Return portable report data for OPERATION."
  (list :id (etaf-performance-operation-id operation)
        :kind (etaf-performance-operation-kind operation)
        :label (etaf-performance-operation-label operation)
        :runtime-id (etaf-performance-operation-runtime-id operation)
        :buffer-name (etaf-performance-operation-buffer-name operation)
        :generation-before
        (etaf-performance-operation-generation-before operation)
        :generation-after
        (etaf-performance-operation-generation-after operation)
        :elapsed-ms (etaf-performance-operation-elapsed operation)
        :status (etaf-performance-operation-status operation)
        :gc-count (etaf-performance-operation-gc-count operation)
        :gc-duration-ms (etaf-performance-operation-gc-elapsed operation)
        :metadata
        (etaf-performance--copy-value
         (etaf-performance-operation-metadata operation))
        :stage-summary
        (etaf-performance-operation-stage-summary operation)
        :stages
        (mapcar #'etaf-performance--stage-report-data
                (etaf-performance-operation-stages operation))))

(defun etaf-performance--parse-darwin-power-state
    (battery-output custom-output)
  "Return normalized macOS power state from PMSET outputs.
BATTERY-OUTPUT identifies the active source; CUSTOM-OUTPUT contains settings."
  (let* ((source
          (cond
           ((string-match-p "Battery Power" (or battery-output "")) 'battery)
           ((string-match-p "AC Power" (or battery-output "")) 'ac)
           (t 'unknown)))
         (target-heading
          (pcase source ('battery "Battery Power") ('ac "AC Power") (_ nil)))
         active low-power)
    (dolist (line (split-string (or custom-output "") "\n" t))
      (cond
       ((string-match "^\\(.+ Power\\):[[:space:]]*$" line)
        (setq active (and target-heading
                          (string= (match-string 1 line) target-heading))))
       ((and active
             (string-match
              "^[[:space:]]*lowpowermode[[:space:]]+\\([01]\\)" line))
        (setq low-power (if (string= (match-string 1 line) "1")
                            'on 'off)))))
    (list :source source :low-power-mode (or low-power 'unknown))))

(defun etaf-performance--command-output (program &rest arguments)
  "Return PROGRAM output for ARGUMENTS, or nil on failure."
  (when program
    (with-temp-buffer
      (let ((default-directory temporary-file-directory))
        (when (eq 0 (apply #'call-process program nil t nil arguments))
          (buffer-string))))))

(defun etaf-performance--power-state ()
  "Return a portable local power-state snapshot."
  (if (not (eq system-type 'darwin))
      (list :source 'unknown :low-power-mode 'unknown)
    (let ((pmset (executable-find "pmset")))
      (if (not pmset)
          (list :source 'unknown :low-power-mode 'unknown)
        (etaf-performance--parse-darwin-power-state
         (etaf-performance--command-output pmset "-g" "batt")
         (etaf-performance--command-output pmset "-g" "custom"))))))

(defun etaf-performance-environment-data ()
  "Return the environment snapshot used to interpret latency records."
  (list :emacs-version emacs-version
        :system-type system-type
        :window-system window-system
        :graphic-display (display-graphic-p)
        :frame-pixel-size
        (list (frame-pixel-width) (frame-pixel-height))
        :window-body-pixel-size
        (list (window-body-width nil t) (window-body-height nil t))
        :gc-cons-threshold gc-cons-threshold
        :gc-cons-percentage gc-cons-percentage
        :native-comp-jit-compilation
        (and (boundp 'native-comp-jit-compilation)
             native-comp-jit-compilation)
        :load-average (load-average t)
        :power-state (etaf-performance--power-state)))

;;;###autoload
(cl-defun etaf-performance-report-data
    (&optional (records (etaf-performance-records)))
  "Return a portable report for completed performance RECORDS.
Omitted RECORDS selects all retained records; explicit nil selects none."
  (list :format-version etaf-performance-report-format-version
        :generated-at (format-time-string "%Y-%m-%dT%H:%M:%S%z")
        :environment (etaf-performance-environment-data)
        :summary (etaf-performance-summary records)
        :operations
        (mapcar #'etaf-performance--operation-report-data
                (reverse (copy-sequence records)))))

;;;###autoload
(cl-defun etaf-performance-report-string
    (&optional (records (etaf-performance-records)))
  "Return completed performance RECORDS as a readable report string.
Omitted RECORDS selects all retained records; explicit nil selects none."
  (concat ";; ETAF performance report\n"
          (pp-to-string (etaf-performance-report-data records))))

;;;###autoload
(defun etaf-performance-copy-report ()
  "Copy all retained performance records to the kill ring."
  (interactive)
  (let* ((record-count (length (etaf-performance-records)))
         (report (etaf-performance-report-string)))
    (kill-new report)
    (message "Copied %d ETAF performance operation%s"
             record-count (if (= 1 record-count) "" "s"))
    report))

;;;###autoload
(defun etaf-performance-export (file)
  "Export all retained performance records to FILE.

When called interactively, suggest a timestamped `.eld' file.  Refuse to
overwrite an existing file."
  (interactive
   (list
    (read-file-name
     "Export ETAF performance report: " nil
     (expand-file-name
      (format "etaf-performance-%s.eld"
              (format-time-string "%Y%m%d-%H%M%S"))
      default-directory))))
  (let ((report (etaf-performance-report-string)))
    (write-region report nil file nil 'silent nil 'excl)
    (message "Exported %d ETAF performance operations to %s"
             (length (etaf-performance-records))
             (abbreviate-file-name file))
    file))

(defun etaf-performance--format-object (value)
  "Format VALUE compactly for the performance table."
  (if (null value) "-" (format "%s" value)))

(defun etaf-performance--tabulated-entries ()
  "Return tabulated entries for retained operations and flat stages."
  (let (entries)
    (dolist (operation (reverse (etaf-performance-records)))
      (let ((id (etaf-performance-operation-id operation)))
        (push
         (list (cons 'operation id)
               (vector (number-to-string id)
                       (symbol-name (etaf-performance-operation-kind operation))
                       (or (etaf-performance-operation-label operation) "")
                       "operation" "-" "-"
                       (format "%.3f"
                               (etaf-performance-operation-elapsed operation))
                       (symbol-name
                        (etaf-performance-operation-status operation))
                       (etaf-performance--format-object
                        (etaf-performance-operation-buffer-name operation))))
         entries)
        (dolist (stage (etaf-performance-operation-stages operation))
          (push
           (list (cons id (etaf-performance-stage-sequence stage))
                 (vector
                  (format "%s.%s" id
                          (etaf-performance-stage-sequence stage))
                  "stage"
                  (symbol-name (etaf-performance-stage-name stage))
                  (symbol-name (etaf-performance-stage-category stage))
                  (symbol-name (etaf-performance-stage-provider stage))
                  (number-to-string
                   (etaf-performance-stage-sequence stage))
                  (format "%.3f" (etaf-performance-stage-duration stage))
                  (symbol-name (etaf-performance-stage-status stage))
                  "-"))
           entries))))
    (nreverse entries)))

(defun etaf-performance--panel-environment-line (&optional environment)
  "Return one compact header for performance ENVIRONMENT."
  (let* ((environment (or environment
                          (etaf-performance-environment-data)))
         (power (plist-get environment :power-state))
         (load (car (plist-get environment :load-average))))
    (format " ETAF Performance | Emacs %s | power %s/low:%s | load %.2f "
            (or (plist-get environment :emacs-version) "unknown")
            (or (plist-get power :source) 'unknown)
            (or (plist-get power :low-power-mode) 'unknown)
            (or load 0.0))))

(define-derived-mode etaf-performance-panel-mode
  tabulated-list-mode "ETAF-Performance"
  "Display ETAF operations and their flat provider reports."
  (setq tabulated-list-format
        [("ID" 9 t) ("Type" 10 t) ("Operation / Stage" 26 t)
         ("Category" 12 t) ("Provider" 12 t) ("Sequence" 9 t)
         ("Duration ms" 13 t) ("Status" 8 t) ("Buffer" 20 t)])
  (setq tabulated-list-padding 2
        tabulated-list-entries #'etaf-performance--tabulated-entries
        header-line-format (etaf-performance--panel-environment-line))
  (tabulated-list-init-header))

(define-key etaf-performance-panel-mode-map (kbd "c")
            #'etaf-performance-copy-report)
(define-key etaf-performance-panel-mode-map (kbd "w")
            #'etaf-performance-export)

;;;###autoload
(defun etaf-performance-show ()
  "Show retained ETAF operations and stages in a tabulated panel."
  (interactive)
  (let ((buffer (get-buffer-create "*ETAF Performance*")))
    (with-current-buffer buffer
      (etaf-performance-panel-mode)
      (tabulated-list-print t))
    (pop-to-buffer buffer)))

(provide 'etaf-performance)

;;; etaf-performance.el ends here