~evhan/beaker

ref: ff2aa6197e1a2e681c4fb02ee53d18ad9e3fe86e beaker/lib/beaker/system.scm -rw-r--r-- 4.2 KiB
ff2aa619Evan Hanson Import beaker sources 3 years ago
                                                                                
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
28
29
30
31
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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A system-style API for eggs.
;;;
;;; Copyright (c) 2018, 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/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 ...
;;
;; Note that import libraries are not currently considered, so changes
;; to a module's export list will not be reflected 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 extension)
  (make-pathname (egg-path egg-file) (symbol->string extension) "so"))

(define (load-extension egg-file extension)
  (let* ((lib (compiled-extension-path egg-file extension))
         (lib-time (file-modification-time lib)))
    (when (< (hash-table-ref/default *library-table* extension 0) lib-time)
      (hash-table-set! *library-table* extension 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)
          (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)))
               (egg-extensions egg-file)))))

;;
;; Builds and loads the given egg.
;;
;; When called for the first time, all out-of-date components are
;; recompiled and the egg's extension libraries are loaded into the
;; calling program.
;;
;; Subsequent calls cause components to be recompiled to be 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)))
            (egg-extensions egg-file)))