syrup/exports.lisp

(in-package #:syrup)
;; Support for inline and in-file symbol exports.

(defvar *capture-exports* nil
  "If non-nil, #^ won't export symbols, and will instead add to *exports*. Either T, NIL, or a specific package to monitor.")
(defvar *exports* nil
  "List of captured symbol exports.")

(defvar *package-files-table* (make-hash-table :weakness :key :synchronized t)
  "Hashtable of per-package file lists which exported symbols via Syrup macros.")

(defun mark-package-file ()
  (pushnew (or *compile-file-truename* *load-truename*)
   (gethash *package* *package-files-table*)))

;; #^ - Inline symbol export macro
;; Use #^SYMBOL or #^(SYMBOL) to export a symbol at the location it's defined.
(defun read-exported-symbol (stream char arg)
  "Read a symbol (optionally wrapped in parens) and export it"
  (declare (ignore char arg))
  (let ((sym (read stream t nil t)))
    (when (and (consp sym) (not (cdr sym)))
      (setf sym (car sym))) ;; allow wrapping symbol in parens
    (unless (symbolp sym)
      (error 'simple-reader-error
             :stream stream
             :format-control "Not a symbol: ~S"
             :format-arguments (list sym)))
    (if *capture-exports*
        (when (or (eq t *capture-exports*) (eq *package* *capture-exports*))
          (push sym *exports*))
        (progn (mark-package-file)
               (export sym)))
    sym))
(set-dispatch-macro-character #\# #\^ #'read-exported-symbol)

(defun ensure-symbol (sym)
  (etypecase sym
    (symbol
     (if (and (symbol-package sym) (not (keywordp sym)))
         sym
         (intern (symbol-name sym))))
    (string
     (intern sym))))

(defmacro export* (&rest symbols)
  (mark-package-file)
  `(export ',(mapcar #'ensure-symbol symbols)))

(defun read-stream-for-exports (stream &optional target-package)
  "Read Lisp source code from STREAM to determine the list of symbols it exports."
  (when target-package
    (let ((pkg (find-package target-package)))
      (unless pkg (error "No such package: ~S" target-package))
      (setf target-package pkg)))
  (let ((*package* *package*)
        (*readtable* *readtable*)
        (*capture-exports* (or target-package t))
        (*exports* nil)
        (eof-sentinel (make-symbol "eof-sentinel")))
    (loop for form = (read stream nil eof-sentinel)
          until (eq form eof-sentinel)
          do (when (consp form)
               (case (car form)
                 (in-package
                  (let ((pkg (find-package (cadr form))))
                    (unless pkg (error "No such package: ~S" (cadr form)))
                    (setf *package* pkg)
                    (when (eq t *capture-exports*)
                      (setf *capture-exports* pkg))))
                 (export*
                  (when (eq *package* *capture-exports*)
                    (setf *exports* (nconc (mapcar #'ensure-symbol (cdr form)) *exports*)))))))
    *exports*))

(defmacro defpackage* (package-name &rest options)
  "Wrapper around uiop:define-package that tries to be aware of symbols exported in other files."
  (let ((extra-exports nil)
        (pkg (find-package package-name)))
    (when pkg
      ;; We're redefining the package, so let's scan the files we know about for exported symbols.
      ;; This prevents them from being un-exported if the files are re-loaded out of order.
      (dolist (pathname (gethash pkg *package-files-table*))
        (let ((exports (with-open-file (stream pathname :if-does-not-exist nil)
                         (read-stream-for-exports stream pkg))))
          (format *error-output* "Exports from ~S:~%  ~S~%" pathname exports)
          (setf extra-exports (nconc exports extra-exports)))))
    `(uiop:define-package ,package-name
       (:export ,@(cdr (assoc :export options)) ,@extra-exports)
       ,@(remove :export options :key #'car))))