source-map.el 8.8 KB
Newer Older
Zach S's avatar
Zach S committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27
;;; 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)
Zach S's avatar
Zach S committed
28
(require 'pp)
Zach S's avatar
Zach S committed
29
(eval-when-compile
30 31
  (require 'cl-lib)
  (require 'subr-x))
Zach S's avatar
Zach S committed
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196

(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")

197
(defun source-map-file (file &optional output-file-name)
Zach S's avatar
Zach S committed
198 199 200 201 202 203 204 205
  "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))
206 207 208 209 210
  (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)))
Zach S's avatar
Zach S committed
211 212 213 214 215
         (print-level nil)
         (print-length nil)
         (print-gensym t)
         (print-circle t)
         (sexp-index 0)
Zach S's avatar
Zach S committed
216 217
         (input-buffer (generate-new-buffer " *source-map-input-file*"))
         (output-buffer (generate-new-buffer " *source-map-output-file*")))
Zach S's avatar
Zach S committed
218 219
    (unwind-protect
        (save-current-buffer
Zach S's avatar
Zach S committed
220
          (set-buffer input-buffer)
Zach S's avatar
Zach S committed
221
          (insert-file-contents file)
Zach S's avatar
Zach S committed
222
          (set-buffer output-buffer)
Zach S's avatar
Zach S committed
223
          (set-visited-file-name dest :no-query)
Zach S's avatar
Zach S committed
224 225 226 227 228 229 230 231 232 233 234
          (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)))
Zach S's avatar
Zach S committed
235
          (pp-buffer)
Zach S's avatar
Zach S committed
236
          (save-buffer))
Zach S's avatar
Zach S committed
237 238
      (kill-buffer output-buffer)
      (kill-buffer input-buffer))))
Zach S's avatar
Zach S committed
239 240 241

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