;;; source-map.el --- Source code mapping -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2020 Zach Shaftel
;;
;; Author: Zach Shaftel
;; Maintainer: Zach Shaftel <zshaftel@gmail.com>
;; Created: July 11, 2020
;; Modified: July 11, 2020
;; Version: 0.0.1
;; Keywords:
;;
;; This file is not part of GNU Emacs.
;;
;;; Commentary:
;;
;;  This library offers the function `source-map-read', which behaves like
;;  `read' on a buffer, but instead of returning the expression itself it
;;  returns a `source-map-expression' struct.
;;
;;  The actual expression can be accessed in the struct with
;;  `source-map-expression-sexp'. `source-map-expression-start' and
;;  `source-map-expression-end' are the bounds of the buffer where the
;;  expression was read.
;;
;;; Code:

(require 'edebug)
(require 'pp)
(eval-when-compile
  (require 'cl-lib)
  (require 'subr-x))

(cl-defstruct (source-map-expression
                (:constructor nil)
                (:copier source-map-copy))
  (sexp nil :documentation "\
The expression that was read.")
  members
  (start nil :documentation "\
The start index of the expression in the original source code.")
  (end nil :documentation "\
The end index of the expression in the original source code.")
  (code nil :documentation "\
The original string of code that was read."))

(cl-defstruct (source-map-symbol
                (:conc-name source-map--symbol)
                (:copier nil)
                (:constructor source-map-symbol)
                (:include source-map-expression)))

(cl-defstruct (source-map-number
                (:conc-name source-map--number)
                (:copier nil)
                (:constructor source-map-number)
                (:include source-map-expression)))

(cl-defstruct (source-map-list
                (:conc-name source-map--list)
                (:copier nil)
                (:constructor source-map-list)
                (:include source-map-expression
                          (members nil :documentation "\
A list of `source-map-expressions' for each subexpression in the
sexp."))))

(cl-defstruct (source-map-vector
                (:conc-name source-map--vector)
                (:copier nil)
                (:constructor source-map-vector)
                (:include source-map-expression
                          (members nil :documentation "\
A vector of `source-map-expressions' for each subexpression in
the sexp."))))

(cl-defstruct (source-map-string
                (:conc-name source-map--string)
                (:copier nil)
                (:constructor source-map-string)
                (:include source-map-expression)))

(cl-defstruct (source-map-record
                (:conc-name source-map--record)
                (:copier nil)
                (:constructor source-map-record)
                (:include source-map-expression)))

(cl-defstruct (source-map-hash-table
                (:conc-name source-map--hash-table)
                (:copier nil)
                (:constructor source-map-hash-table)
                (:include source-map-expression)))

(cl-defstruct (source-map-char-table
                (:conc-name source-map--char-table)
                (:copier nil)
                (:constructor source-map-char-table)
                (:include source-map-expression)))

(cl-defstruct (source-map-byte-code
                (:conc-name source-map--byte-code)
                (:copier nil)
                (:constructor source-map-byte-code)
                (:include source-map-expression)))

(cl-defstruct (source-map-other
                (:conc-name source-map--other)
                (:copier nil)
                (:constructor source-map-other)
                (:include source-map-expression)))

(cl-defstruct (source-map-top-level-form
                (:copier source-map-copy-top-level-form)
                (:constructor source-map-top-level-form))
  "A wrapper around the `source-map-expression' for the INDEXth
top level form in a file."
  index
  expression)

(defun source-map--wrap (obj &optional members start end code)
  "Create a `source-map-expression' for OBJ, optionally supplying additional slots."
  ;; FIXME should nil be a `source-map-symbol' or `source-map-list'?
  (record (cond
            ((listp obj) 'source-map-list)
            ((symbolp obj) 'source-map-symbol)
            ((vectorp obj) 'source-map-vector)
            ((stringp obj) 'source-map-string)
            ((numberp obj) 'source-map-number)
            ((recordp obj) 'source-map-record)
            ((hash-table-p obj) 'source-map-hash-table)
            ((char-table-p obj) 'source-map-char-table)
            ((byte-code-function-p obj) 'source-map-byte-code)
            (t 'source-map-other))
          obj members start end code))

(defun source-map--copy-thing (thing)
  "If THING is a vector or cons, copy it, else return it.
Unlike `copy-sequence', this function can (attempt to) copy
dotted and circular lists."
  (condition-case nil
      (if (or (consp thing) (vectorp thing))
          (copy-sequence thing)
        thing)
    ((wrong-type-argument circular-list)
     ;; THING is a circular or dotted list, gotta do this the hard way
     ;; REVIEW
     (let* ((slen (safe-length thing))
            (r (make-list slen nil))
            (tail r))
       (while (and (> slen 0) (consp (cdr thing)))
         (setq slen (1- slen))
         (setcar tail (car thing))
         (setq thing (cdr thing))
         (setq tail (cdr tail)))
       (setcdr tail (if (consp (cdr thing)) r thing))
       r))))

(defun source-map--process (sexp offsets)
  "Recursively construct a `source-map-expression' for SEXP at source code OFFSETS."
  (let* ((orig-sexp sexp)
         (abstract (source-map--copy-thing sexp))
         (start (car offsets)))
    (if (atom abstract)
        ;; not a cons, so if OFFSETS isn't a '(START . END) pair then this is a
        ;; vector. if it is, the body of the loop won't be entered.
        (let ((index 0))
          (while (consp (setq offsets (cdr offsets)))
            (aset abstract index
                  (source-map--process (aref sexp index) (car offsets)))
            (setq index (1+ index))))
      ;; it's a cons, so add a dummy to the front of ABSTRACT so we can setcdr
      ;; the end
      (let ((abstract (cons nil abstract)))
        (while (consp (setq offsets (cdr offsets)))
          (if (atom sexp)
              (setcdr abstract (source-map--process sexp (car offsets)))
            (setcar (setq abstract (cdr abstract))
                    (source-map--process (car sexp) (car offsets)))
            (setq sexp (cdr sexp))))))
    (source-map--wrap orig-sexp abstract start offsets
                      (buffer-substring-no-properties start offsets))))

(defun source-map-read (&optional stream)
  "Read STREAM and return a `source-map-expression' for the read form.
STREAM (or `standard-input' if nil) must be a buffer."
  (with-current-buffer (or stream standard-input)
    (edebug-skip-whitespace)
    (let* ((edebug-offsets nil)
           (edebug-offsets-stack nil)
           (edebug-current-offset nil))
      (source-map--process
       (edebug-read-storing-offsets (current-buffer))
       edebug-offsets))))

(defconst source-map-file-name-extension ".eld")

(defun source-map-file (file &optional output-file-name)
  "Emit source-code mappings for FILE.

FILE should contain ELisp. A new file is created in the same
directory with the `source-map-file-name-extension' extension.
The file contains `source-map-top-level-form's for each top level
expression in FILE."
  (interactive "fFile to map: ")
  (setq file (expand-file-name file))
  (let* ((dest (thread-first (if output-file-name
                                 (expand-file-name output-file-name)
                               file)
                 (file-name-sans-extension)
                 (concat source-map-file-name-extension)))
         (print-level nil)
         (print-length nil)
         (print-gensym t)
         (print-circle t)
         (sexp-index 0)
         (input-buffer (generate-new-buffer " *source-map-input-file*"))
         (output-buffer (generate-new-buffer " *source-map-output-file*")))
    (unwind-protect
        (save-current-buffer
          (set-buffer input-buffer)
          (insert-file-contents file)
          (set-buffer output-buffer)
          (set-visited-file-name dest :no-query)
          (save-current-buffer          ;just in case
            (condition-case nil
                (while t
                  (prin1 (source-map-top-level-form
                          :index sexp-index
                          :expression (source-map-read input-buffer))
                         output-buffer)
                  (goto-char (point-max))
                  (terpri)
                  (setq sexp-index (1+ sexp-index)))
              (end-of-file nil)))
          (pp-buffer)
          (save-buffer))
      (kill-buffer output-buffer)
      (kill-buffer input-buffer))))

(provide 'source-map)
;;; source-map.el ends here