;;; dired-view-data.el --- View data from dired via ESS and R  -*- lexical-binding: t; -*-

;; Copyright (C) 2021 - 2026  Shuguang Sun

;; Author: Shuguang Sun <shuguang79@qq.com>
;; Created: 2021/03/28
;; Package-Version: 20260822.1255
;; Package-Revision: dd1aeb67a593
;; URL: https://github.com/ShuguangSun/dired-view-data
;; Package-Requires: ((emacs "26.1") (ess "18.10.1") (ess-view-data "1.5"))
;; Keywords: tools

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

;; View data files from Dired via ESS and R.
;;
;; (require 'dired-view-data)
;; (dired-view-data-global-mode)
;;
;; or enable the minor mode in Dired buffers manually:
;; (dired-view-data-mode 1)

;; In a Dired buffer, call `dired-view-data' (`V' or `C-c C-v') on a
;; data file (sas7bdat, xpt, xlsx/xls, parquet, sav, dta, rds, csv,
;; tsv, rda or rdata) and a buffer pops up with the data rendered by
;; `ess-view-data'.

;; Add or change formats via `dired-view-data-data-name-format'.
;; Quit the R session with `dired-view-data-quit-session'.

;; Optionally set `dired-view-data-guess-shell-alist-p' to t to also
;; hook `dired-do-shell-command' (`!') for those files; it is off by
;; default.  See NEWS.md for what changed in version 2.

;;; Code:

(require 'dired)
(require 'ess-r-mode)
(require 'ess-inf)
(require 'ess-view-data)
;; (require 'ob-R) ;; org-babel-R-initiate-session


(defgroup dired-view-data ()
  "Read data from Dired, for example, sas7bdat for SAS."
  :group 'ess
  :prefix "dired-view-data-")

(defcustom dired-view-data-session-buffer-name "*R: View File*"
  "Name of the R session buffer used for data post-handling."
  :type 'string
  :group 'dired-view-data)

(defcustom dired-view-data-history-file nil
  "File to pick up history from.  nil means *no* history is read or written.
t means something like \".Rhistory\".
If this is a relative file name, it is relative to `ess-history-directory'.
Consequently, if that is set explicitly, you will have one history file
for all projects.
This is local version of `ess-history-file.'"
  :type '(choice (const nil) (const t) string)
  :group 'dired-view-data)

(defcustom dired-view-data-default-directory nil
  "Where to start the R session.
nil means the directory of the viewed data file; a directory
means start every R session from it globally."
  :type 'directory
  :safe 'stringp
  :group 'dired-view-data)

(defcustom dired-view-data-guess-shell-alist-p nil
  "Whether to add `dired-view-data' to `dired-guess-shell-alist-user'.
When enabled, pressing \\[dired-do-shell-command] (`!') on a data
file offers reading it into an R session instead of running a
shell command.  Off by default because the integration hijacks
the `shell-command' flow."
  :type 'boolean
  :group 'dired-view-data)


(defcustom dired-view-data-data-name-format
  '((sas7bdat
     :read "%1$s <- haven::read_sas(%2$s)"
     :view dired-view-data-view
     :packages (haven)
     :doc "Read SAS datasets with haven.")
    (xpt
     :read "%1$s <- {if(requireNamespace(\"haven\", quietly=TRUE)) haven::read_xpt(%2$s) else foreign::read.xport(%2$s)}"
     :view dired-view-data-view
     :packages nil
     :doc "Read SAS transport files; haven when available, else foreign.")
    (rda
     :read "%1$s <- get(load(%2$s)[1])"
     :view dired-view-data-view
     :packages nil
     :doc "Read the first object of a save file.")
    (rdata
     :read "%1$s <- get(load(%2$s)[1])"
     :view dired-view-data-view
     :packages nil
     :doc "Read the first object of a save file.")
    (rds
     :read "%1$s <- readRDS(%2$s)"
     :view dired-view-data-view
     :packages nil
     :doc "Read a single R object with readRDS.")
    (csv
     :read "%1$s <- data.table::fread(%2$s)"
     :view dired-view-data-view
     :packages (data.table)
     :doc "Read CSV files with data.table::fread.")
    (tsv
     :read "%1$s <- data.table::fread(%2$s)"
     :view dired-view-data-view
     :packages (data.table)
     :doc "Read TSV files with data.table::fread.")
    (xlsx
     :read "%1$s <- readxl::read_excel(%2$s)"
     :view dired-view-data-view
     :packages (readxl)
     :doc "Read the first sheet of an xlsx workbook with readxl.")
    (xls
     :read "%1$s <- readxl::read_excel(%2$s)"
     :view dired-view-data-view
     :packages (readxl)
     :doc "Read the first sheet of an xls workbook with readxl.")
    (parquet
     :read "%1$s <- arrow::read_parquet(%2$s)"
     :view dired-view-data-view
     :packages (arrow)
     :doc "Read a Parquet file with arrow.")
    (sav
     :read "%1$s <- haven::read_sav(%2$s)"
     :view dired-view-data-view
     :packages (haven)
     :doc "Read SPSS files with haven::read_sav.")
    (dta
     :read "%1$s <- haven::read_dta(%2$s)"
     :view dired-view-data-view
     :packages (haven)
     :doc "Read Stata files with haven::read_dta."))
  "Alist of data format (file extension) and how to read and display it.

The file extension as key must be in down-case.  The value is a
plist:

:read      format string for the R code reading the file; it takes
           two OBJECTS: the R object name to create, and the file
           name already quoted as an R string literal by
           `dired-view-data--r-quote-path'
:view      display function called with the object name, or a
           format string to be formatted with the object name and
           sent by `ess-send-string'
:packages  list of R packages required for reading, checked in
           the session before any code is sent; nil means base R
           only, or a reader that falls back on its own (xpt)
:doc       one-line description of the entry"
  :type '(alist :key-type (symbol :tag "ext")
                :value-type
                (plist :options
                       ((:read (string :tag "format string for read data"))
                        (:view (choice (string :tag "format string for display")
                                       (function :tag "Function to display")))
                        (:packages (repeat :tag "Required R packages" symbol))
                        (:doc (string :tag "Description")))))
  :group 'dired-view-data)

(defun dired-view-data--format-entry (ext)
  "Return the registered plist for the down-case EXT, or nil."
  (alist-get (intern (downcase ext)) dired-view-data-data-name-format))


(defun dired-view-data--r-quote-path (path)
  "Return PATH as a quoted R string literal.
Convert backslashes to forward slashes and escape single quotes,
so that arbitrary file names can be embedded in generated R code."
  (concat "'"
          ;; Literal replacement without `string-replace', which is
          ;; not available before Emacs 28.1.
          (mapconcat #'identity
                     (split-string
                      (replace-regexp-in-string "\\\\" "/" path)
                      "'")
                     "\\'")
          "'"))

(defun dired-view-data--sanitize-object-name (name)
  "Return NAME as a valid R variable name.
Replace every character that is not allowed in a syntactic R name
with an underscore, and prefix names starting with a digit or an
underscore."
  (let ((clean (replace-regexp-in-string "[^[:alnum:].]" "_" name)))
    (if (string-match-p "\\`[0-9_]" clean)
        (concat "d." clean)
      clean)))

(defvar-local dired-view-data--object-history nil
  "Object names already created in this session's R process.
Buffer-local in the session buffer: a fresh R session starts from
an empty namespace, while a reused one keeps deduplicating.")

(defun dired-view-data--r-eval-words (session expression)
  "Evaluate R EXPRESSION in SESSION, return the result words.
Return the symbol \\='busy while the session's process reports
itself busy (callers should wait instead of queueing another
query), and nil when evaluation fails; the underlying error is
reported so silent degradations stay diagnosable."
  (let ((proc (get-buffer-process session)))
    (cond ((not (process-live-p proc))
           (message "No live R process in %s" session)
           nil)
          ((process-get proc 'busy) 'busy)
          (t
           (condition-case err
               (ess-get-words-from-vector expression nil nil proc)
             (error
              (message "R round-trip failed: %s"
                       (error-message-string err))
              nil))))))

(defun dired-view-data--missing-r-packages (session packages)
  "Return the R PACKAGES missing in SESSION, or \\='unknown.
\\='unknown means availability could not be determined and callers
should degrade gracefully instead of blocking the user."
  (cond ((null packages) nil)
        ((not (fboundp 'ess-get-words-from-vector)) 'unknown)
        (t
         (let* ((expr (concat "c("
                              (mapconcat
                               (lambda (pkg)
                                 (format "nzchar(system.file(package=%S))"
                                         (symbol-name pkg)))
                               packages
                               ",")
                              ")\n"))
                (words (dired-view-data--r-eval-words session expr)))
           (if (or (not (listp words))    ; 'busy
                   (/= (length words) (length packages)))
               'unknown
             (let (missing)
               (while (and packages words)
                 (unless (string= (car words) "TRUE")
                   (push (car packages) missing))
                 (setq packages (cdr packages)
                       words (cdr words)))
               (nreverse missing)))))))

(defcustom dired-view-data-verify-timeout 10
  "Seconds to keep re-checking that the loaded object appeared in R.
The check is an ordinary R round-trip, so it queues behind the
read command and only ever reports once the read has finished."
  :type 'number
  :group 'dired-view-data)

(defun dired-view-data--object-exists-p (session object)
  "Check non-nil when OBJECT exists in the SESSION's R process.
Return \\='busy while SESSION's process is still working (so
callers do not queue yet another query behind a long-running job)
and \\='unknown when the round-trip is unavailable or fails."
  (if (not (fboundp 'ess-get-words-from-vector))
      'unknown
    (let ((words (dired-view-data--r-eval-words
                  session
                  (format "exists(\"%s\", inherits=FALSE)\n" object))))
      (cond ((eq words 'busy) 'busy)
            ((null words) 'unknown)
            ((member "TRUE" words) t)
            (t nil)))))

(defun dired-view-data--verify-object (session object timeout)
  "Wait until OBJECT exists in SESSION, at most TIMEOUT seconds.
Signal a `user-error' when the object never shows up; stay quiet
when existence cannot be checked at all.  Unavailable round-trips
are retried within the same window, so startup turbulence does
not abort the check; while R is busy only waiting happens, no new
queries are queued."
  (let ((status (dired-view-data--object-exists-p session object))
        (deadline (+ (float-time) timeout)))
    (while (and (memq status '(nil unknown busy))
                (< (float-time) deadline))
      (sleep-for 0.5)
      (setq status (dired-view-data--object-exists-p session object)))
    (cond ((eq status t))
          ((eq status 'busy)
           ;; A long read may simply outrun the window: say so
           ;; instead of claiming the object is missing.
           (message "R is still loading `%s'; nothing displayed yet"
                    object))
          ((eq status 'unknown)
           (message "Cannot verify the loaded object; continuing"))
          (t
           (user-error
            "Object `%s' did not appear; see buffer %s"
            object session)))))

(defun dired-view-data--new-object-name (base)
  "Return a valid R name derived from BASE, unused so far.
Call with the session buffer current: the history is buffer-local
there.  The name is NOT recorded; call
`dired-view-data--record-object-name' only once the object has
actually been created, so failed attempts do not burn uniqueness
suffixes."
  (let* ((sanitized (dired-view-data--sanitize-object-name base))
         (name sanitized)
         (i 1))
    (while (member name dired-view-data--object-history)
      (setq i (1+ i)
            name (format "%s.%d" sanitized i)))
    name))

(defun dired-view-data--record-object-name (name)
  "Remember NAME in the current buffer's `dired-view-data--object-history'."
  (push name dired-view-data--object-history))


(defcustom dired-view-data-session-start-timeout 30
  "Seconds to wait for a newly started R session to become ready."
  :type 'number
  :group 'dired-view-data)

;; this is from ob-comint, renamed here to avoid loading the heavy org package
(defun dired-view-data-R-buffer-livep (buffer)
  "Check if BUFFER is a comint buffer with a live process."
  (let ((buffer (when buffer (get-buffer buffer))))
    (and buffer (buffer-live-p buffer) (get-buffer-process buffer) buffer)))

(defun dired-view-data--wait-session-ready (proc timeout)
  "Wait for the R process PROC to become interactive.
Wait at most TIMEOUT seconds for pending callbacks to drain AND
the ESS busy flag to clear: ESS marks the inferior busy while it
runs its startup hooks (e.g. ess-tracebug), and round-trips sent
during that window fail with \"process not ready\".  Signal an
error when PROC dies or is still not ready by the deadline."
  (let ((deadline (+ (float-time) timeout)))
    (while (and (< (float-time) deadline)
                (or (process-get proc 'callbacks)
                    (process-get proc 'busy)))
      (accept-process-output proc 0.2))
    (unless (process-live-p proc)
      (error "R process died while starting"))
    (when (or (process-get proc 'callbacks)
              (process-get proc 'busy))
      (error "R session not ready within %s seconds"
             timeout))))

(defun dired-view-data--ensure-session (session dir)
  "Return the live ESS R session buffer named SESSION.
Start a new R process with `default-directory' DIR when SESSION
does not exist yet or its process has died."
  (or (dired-view-data-R-buffer-livep session)
      (let ((ess-ask-for-ess-directory nil)
            (default-directory (or dir default-directory)))
        ;; Kill any stale buffer occupying SESSION first, otherwise
        ;; `rename-buffer' would uniquify the new name and every later
        ;; call would start yet another R process.
        (let ((stale (get-buffer session)))
          (when stale
            (if (provided-mode-derived-p
                 (buffer-local-value 'major-mode stale) 'comint-mode)
                (kill-buffer stale)
              (error "Buffer %S exists and is not an ESS session" session))))
        (save-window-excursion
          (require 'ess)
          (R)
          ;; `R' leaves the fresh inferior buffer current.
          (rename-buffer session)
          (let ((proc (get-buffer-process (current-buffer))))
            (unless (process-live-p proc)
              (error "Failed to start R"))
            (dired-view-data--wait-session-ready
             proc dired-view-data-session-start-timeout))
          (current-buffer)))))


(defun dired-view-data-view (dt)
  "Display the dataset named DT in an `ess-view-data' buffer.
How the data is rendered is up to `ess-view-data', e.g. see
`ess-view-data-display-backend'."
  (pop-to-buffer (ess-view-data-print-ex dt)))

(defun dired-view-data--build-read-code (entry object quoted-path)
  "Return the R read expression registered in ENTRY.
It assigns the dataset at QUOTED-PATH to OBJECT."
  (format (concat (plist-get entry :read) "\n") object quoted-path))

(defun dired-view-data--send-to-session (session code)
  "Send CODE to the live R process of SESSION.
Resolve the process through SESSION itself, never through global
ESS state, so code cannot leak into an unrelated inferior."
  (let ((proc (get-buffer-process session)))
    (if (not (process-live-p proc))
        (error "No live R process in %s" session)
      (ess-send-string proc code t))))

(defun dired-view-data--display (session entry object)
  "Display OBJECT from SESSION as specified by ENTRY's :view.
A function is called with OBJECT; a string is formatted with
OBJECT and sent to SESSION like ordinary read code."
  (let ((view (plist-get entry :view)))
    (cond ((functionp view)
           ;; Historical settle delay before the display round-trip.
           ;; ess-view-data resolves the process from the current
           ;; buffer, so the function MUST run in the session.
           (sleep-for 1)
           (with-current-buffer session
             (funcall view object)))
          ((stringp view)
           (dired-view-data--send-to-session
            session (format view object)))
          (t (error "Bad :view spec %S" view)))))

(defun dired-view-data--do (file-name)
  "Read data from FILE-NAME into the R session and display it.
`dired-view-data' validates FILE-NAME before calling here."
  (save-excursion
    (let* ((default-directory (or dired-view-data-default-directory default-directory))
           (ess-history-file dired-view-data-history-file)
           (ext (downcase (or (file-name-extension file-name) "")))
           (dt-dir (file-name-directory file-name))
           (entry (dired-view-data--format-entry ext))
           readdt
           session
           dt-name)
      (unless entry
        (user-error "Unsupported file type `%s'" ext))
      (progn
        (setq session (dired-view-data--ensure-session
                       dired-view-data-session-buffer-name dt-dir))
        ;; Names are unique per session: derive them inside the
        ;; session buffer so its buffer-local history applies.
        (setq dt-name (with-current-buffer session
                        (dired-view-data--new-object-name
                         (file-name-base file-name))))
        (let ((missing (dired-view-data--missing-r-packages
                        session (plist-get entry :packages))))
          (cond ((eq missing 'unknown)
                 (message
                  "Cannot verify required R packages; continuing"))
                (missing
                 (user-error
                  "Missing R package(s) %s; in R run: install.packages(c(%s))"
                  (mapconcat #'symbol-name missing ", ")
                  (mapconcat (lambda (p) (format "%S" (symbol-name p)))
                             missing ", ")))))
        (setq readdt (dired-view-data--build-read-code
                      entry dt-name (dired-view-data--r-quote-path file-name)))
        (dired-view-data--send-to-session session readdt)
        (with-current-buffer session
          (ess-switch-to-ESS t))
        ;; The verification round-trip queues behind the read
        ;; command, so it doubles as a barrier before displaying.
        (dired-view-data--verify-object
         session dt-name dired-view-data-verify-timeout)
        ;; Record in the session only once the object really
        ;; exists, so failed attempts do not burn unique suffixes.
        (with-current-buffer session
          (dired-view-data--record-object-name dt-name))
        (dired-view-data--display session entry dt-name)
        (message "Loaded %s as `%s' in session %s"
                 file-name dt-name dired-view-data-session-buffer-name)))))


(defun dired-view-data-quit-session ()
  "Quit the R session used for viewing data.
Kill the session buffer named `dired-view-data-session-buffer-name'
and delete its process."
  (interactive)
  (let ((buffer (get-buffer dired-view-data-session-buffer-name)))
    (if (not buffer)
        (message "No %s session" dired-view-data-session-buffer-name)
      (let ((process (get-buffer-process buffer)))
        (when (process-live-p process)
          (set-process-query-on-exit-flag process nil)
          (delete-process process)))
      (kill-buffer buffer)
      ;; Recorded names are buffer-local in the session buffer and
      ;; die with it; nothing to reset here.
      (message "Quit session %s" dired-view-data-session-buffer-name))))

(defun dired-view-data--supported-extensions ()
  "Return the supported file extensions as down-case strings."
  (mapcar (lambda (entry) (symbol-name (car entry)))
          dired-view-data-data-name-format))

;;;###autoload
(defun dired-view-data ()
  "View the data file at point from Dired via ESS/R."
  (interactive)
  (let* ((file-name (dired-get-file-for-visit))
         (ext (downcase (or (file-name-extension file-name) ""))))
    (cond
     ((derived-mode-p 'wdired-mode)
      ;; File names shown by wdired are editable text, not real
      ;; files, so refuse instead of acting on stale paths.
      (user-error "Not available in wdired-mode; finish editing first"))
     ((file-directory-p file-name)
      (user-error "%s is a directory" file-name))
     ((not (file-exists-p file-name))
      (user-error "File does not exist: %s" file-name))
     ((file-remote-p file-name)
      (user-error "Remote files are not supported: %s"
                  file-name))
     ((not (assq (intern ext) dired-view-data-data-name-format))
      (user-error "Unsupported or missing file type `%s'; supported: %s"
                  (if (string= ext "") "(none)" ext)
                  (mapconcat #'identity
                             (dired-view-data--supported-extensions)
                             ", ")))
     (t (dired-view-data--do file-name)))))


(defun dired-view-data--extension-regexp ()
  "Return a regexp matching file names ending in a supported extension.
Derived from `dired-view-data-data-name-format', so new formats
are picked up automatically."
  (format "\\.%s$"
          (regexp-opt (dired-view-data--supported-extensions))))

(defun dired-view-data-guess-shell-alist ()
  "Add an entry to the buffer-local `dired-guess-shell-alist-user'.
The entry reads the file at point into an R session; answering no
falls back to the OS file association on Windows.  Note that Dired
evaluates guess-shell commands with only `file' bound, and that
this function aborts the `shell-command' flow with `keyboard-quit'
after handling the file."
  (interactive)
  (when (derived-mode-p 'dired-mode)
    (add-to-list (make-local-variable 'dired-guess-shell-alist-user)
                 (list (dired-view-data--extension-regexp)
                 '(progn
                    (if (y-or-n-p "Read into R session?")
                        ;; Go through the interactive command so the
                        ;; file gets the same validation as pressing
                        ;; V (directories, remote paths, etc.).
                        (dired-view-data)
                      ;; Otherwise fall back to the OS file
                      ;; association (Windows only).
                      (when (eq system-type 'windows-nt)
                        (w32-shell-execute "open" file nil 1)))
                    (keyboard-quit))))))


(defun dired-view-data-assert-dired-buffer ()
  "Signal an error unless the current buffer is in `dired-mode'."
  (unless (derived-mode-p 'dired-mode)
    (error "Buffer is not in dired-mode!")))


(defvar dired-view-data-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "V") #'dired-view-data)
    (define-key map (kbd "C-c C-v") #'dired-view-data)
    map)
  "The keymap used when `dired-view-data-mode' is active.")

;;;###autoload
(define-minor-mode dired-view-data-mode
  "Toggle viewing data files from the current Dired buffer via ESS/R.
When enabled, \\[dired-view-data] reads the data file at point into
an R session and pops up an `ess-view-data' buffer."
  :global nil
  :lighter " DVD"
  :keymap dired-view-data-mode-map
  :group 'dired-view-data
  (when dired-view-data-mode
    (dired-view-data-assert-dired-buffer)
    (when dired-view-data-guess-shell-alist-p
      (dired-view-data-guess-shell-alist))))

;;;###autoload
(defun dired-view-data-mode-on ()
  "Turn on `dired-view-data-mode'."
  (interactive)
  (when (derived-mode-p 'dired-mode)
    (dired-view-data-mode)))

;;;###autoload
(define-globalized-minor-mode dired-view-data-global-mode dired-view-data-mode
  dired-view-data-mode-on)

(provide 'dired-view-data)
;;; dired-view-data.el ends here
