;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A system-style API for eggs.
;;;
;;; Copyright (c) 2018-2019, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

;;
;; The `(beaker system)` library provides an API for dynamically
;; building, loading, and reloading extension libraries. It's intended
;; to help enable rapid development in a manner similar to [asdf][] from
;; Common Lisp or the [system][] egg from CHICKEN 4.
;;
;; [asdf]: https://common-lisp.net/project/asdf/asdf/index.html
;; [system]: https://wiki.call-cc.org/eggref/4/system
;;
;; Rather than introduce a new way to define a system's components and
;; dependencies, this library reuses the [egg][] specification format.
;; In fact, you can generally think of a "system" and an "egg" as one
;; and the same.
;;
;; [egg]: http://wiki.call-cc.org/man/5/Egg%20specification%20format
;;
;; An example `csi` session that loads, edits, and reloads an example
;; system might look like the following:
;;
;;     #;> (import (beaker system))
;;     #;> (load-system "example.egg")
;;     building example
;;     ... output ...
;;     ; loading /tmp/temp70d6.29489.example.import.so ...
;;     ; loading /tmp/temp4871.29489.example.so ...
;;     #;> (load-system "example.egg")
;;     building example
;;     #;> ,e example.scm
;;     #;> (load-system "example.egg")
;;     building example
;;     ... output ...
;;     ; loading /tmp/temp44a2.29609.example.so ...
;;
;; Modules are imported automatically and import libraries are reloaded
;; whenever a module's exports list changes. Note that removing a value
;; from a module's export list does not remove it from the session when
;; the extension is reloaded.
;;
(declare
  (module (beaker system))
  (export clean-system compile-system load-system)
  (import (beaker egg info)
          (beaker repository)
          (chicken condition)
          (chicken file)
          (chicken file posix)
          (chicken pathname)
          (chicken process)
          (srfi 69)
          (with-current-directory)))

(define *library-table*
  (make-hash-table))

(define (egg-path egg-file)
  (or (pathname-directory egg-file) "."))

(define (compiled-program-path egg-file program)
  (make-pathname (egg-path egg-file) (symbol->string program)))

(define (compiled-extension-path egg-file name extension)
  (make-pathname (egg-path egg-file) (symbol->string name) extension))

(define (load-extension egg-file name extension)
  (let* ((lib (compiled-extension-path egg-file name extension))
         (lib-time (file-modification-time lib))
         (key (pathname-strip-directory lib)))
    (when (< (hash-table-ref/default *library-table* key 0) lib-time)
      (hash-table-set! *library-table* key lib-time)
      (let ((tmp (create-temporary-file (pathname-strip-directory lib))))
        (handle-exceptions e
            (begin (delete-file* tmp) (when (condition? e) (signal e)))
          (copy-file lib tmp #t)
          (load tmp)
          ;; XXX this could be more robust...
          (when (string=? extension "import.so")
            (eval `(import ,name)))
          (signal 'ok))))))

;;
;; Compiles all out-of-date components for the given egg.
;;
;; This is equivalent to running `chicken-install -no-install`.
;;
(define (compile-system egg-file)
  (with-current-directory
   (egg-path egg-file)
   (lambda ()
     (receive (_ _ status) (process-wait (process-run (chicken-install) (list "-no-install")))
       (unless (zero? status)
         (signal (condition '(exn message "failed to compile system"))))))))

;;
;; Deletes all compiled programs and extension libraries for the given egg.
;;
;; Auxiliary files such as import libraries are preserved.
;;
(define (clean-system egg-file)
  (with-current-directory
   (egg-path egg-file)
   (lambda ()
     (for-each (lambda (x)
                 (delete-file* (compiled-program-path egg-file x)))
               (egg-programs egg-file))
     (for-each (lambda (x)
                 (delete-file* (compiled-extension-path egg-file x "so")))
               (egg-extensions egg-file)))))

;;
;; Builds and loads the given egg.
;;
;; When called for the first time, all out-of-date components are
;; recompiled, the egg's extension libraries are loaded into the calling
;; program and its modules are immediately imported.
;;
;; Subsequent calls cause the components to be recompiled and reloaded
;; as necessary.
;;
(define (load-system egg-file #!key (skip '()))
  (compile-system egg-file)
  (for-each (lambda (x)
              (unless (memq x skip)
                (load-extension egg-file x "import.so")))
            (egg-import-libraries egg-file))
  (for-each (lambda (x)
              (unless (memq x skip)
                (load-extension egg-file x "so")))
            (egg-extensions egg-file)))