;;; asdf-generator: generate ASDF .asd files based solely on a list of
;;; system dependencies and files.  Heuristically finds definitions
;;; within the body of code and dependencies between files in the
;;; system, and then generates proper :depends-on clauses.

;;; The first obvious weakness of this is that it doesn't handle
;;; defpackages and in-packages at all, so the reader will intern
;;; unscoped symbols into the wrong package and will utterly fail on
;;; symbols which explicitly reference packages defined by this
;;; system.

(defpackage :net.a1k0n.asdf-generator
  (:nicknames :asdfgen)
  (:use :common-lisp)
  (:export make-asdf))

(in-package :net.a1k0n.asdf-generator)

(defvar *source-file*)
(defvar *definitions*)
(defvar *dependencies*)

(defun add-definition (what where srcform)
  (setf (gethash what *definitions*) (cons where srcform)))

(defun add-dependency (file depends-on)
  (unless (string= file depends-on)
    (pushnew depends-on (gethash file *dependencies*) :test #'equal)))

(defun scan-code-defs (code)
  ;; dumb heuristic: assume the only way to define anything is through
  ;; a function or macro called "DEF*" called at any point in the
  ;; code.
  (when (and (listp code)
             (symbolp (first code)))
    (let ((fn-name (symbol-name (first code))))
      (if (and (> (length fn-name) 3)
               (string= (subseq (symbol-name (first code)) 0 3) "DEF"))
          (add-definition (second code) *source-file* (first code))
          (dolist (c code)
            (scan-code-defs c))))))

(defun scan-code-deps (code)
  (cond
    ;; handle things like '(foo . 5) by making sure the cdr is also a list
    ((and (listp code)
          (listp (cdr code)))
     ;; and don't worry about definitions of quoted things
     (unless (eql (car code) 'quote)
       (dolist (c code)
         (scan-code-deps c))))
    ((symbolp code)
     (let ((def-location (gethash code *definitions*)))
       (when def-location
         (add-dependency *source-file* (car def-location)))))))

;; TODO: actually use Common Lisp's pathname system here
(defun scan-file (pathname fname scan-function)
  (let ((*source-file* fname))
    (with-open-file (srcfile (format nil "~a/~a.lisp" pathname fname) :direction :input)
      (loop for sexp = (read srcfile nil)
            while sexp
            do (funcall scan-function sexp)))))

(defun gen-dependencies (pathname file-list)
  (let ((*definitions* (make-hash-table :test #'equal))
        (*dependencies* (make-hash-table :test #'equal)))
    (format t "Scanning ~a for ~s..." pathname file-list)
    ;; scan through all the code and record all definition forms we
    ;; can find.
    (dolist (file file-list)
      (scan-file pathname file #'scan-code-defs))
    ;; scan through all the code and look for all uses of any of the
    ;; definitions we've found, saving dependencies along the way.
    (dolist (file file-list)
      (scan-file pathname file #'scan-code-deps))
    ;;(describe *definitions*)
    ;;(describe *dependencies*)
    *dependencies*))

;; TODO: detect and verbosely warn about circular dependencies.

;; XXX: I don't see any way around the eval here, since defsystem
;; quotes its arguments, and I need to do the file scanning at load
;; time because that's when *load-truename* is set, and I don't want
;; to rely on *compile-file-truename* being set because ASDF just uses
;; LOAD and not COMPILE.
(defmacro make-asdf (system-name system-dependencies file-list)
  `(let ((file-list ',file-list)
         (system-dependencies ',system-dependencies)
         (system-name ',system-name))
    (dolist (x system-dependencies)
      (asdf:oos 'asdf:load-op x))
    (let* ((pathname (asdf::pathname-sans-name+type
                      (asdf::resolve-symlinks *load-truename*)))
           (deps (gen-dependencies pathname file-list))
           (components (loop for file in file-list
           collect (let ((file-deps (gethash file deps)))
                     (if file-deps
                         `(:file ,file :depends-on ,file-deps)
                         `(:file ,file))))))
      (eval `(asdf:defsystem ,system-name
              :components ,components
              :depends-on ,system-dependencies)))))