about summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--scramble.scm152
1 files changed, 152 insertions, 0 deletions
diff --git a/scramble.scm b/scramble.scm new file mode 100644 index 0000000..e79fbe0 --- /dev/null +++ b/scramble.scm
@@ -0,0 +1,152 @@
1(declare (module scramble))
2
3(import scheme (chicken base)
4 (chicken file)
5 (chicken format)
6 (chicken pathname)
7 (chicken process)
8 (chicken process-context)
9 (chicken string)
10 (srfi 1))
11
12;; dependencies should be like
13;; (((output jimmy.util) (source jimmy.util))
14;; ((output jimmy.read) (source jimmy.read) (source jimmy.util))
15;; ((output jimmy.emit) (source jimmy.emit) (source jimmy.util)))
16
17(define egg (make-parameter #f))
18(define build-dir (make-parameter "build"))
19
20(define csc-options '("-setup-mode"
21 "-host"
22 "-D compiling-extension"
23 "-emit-all-import-libraries"
24 "-dynamic"
25 "-regenerate-import-libraries"
26 "-I $(PWD)"
27 "-C -I$(PWD)"))
28
29(define source-extensions
30 ;; The possible extensions source files can take.
31 (make-parameter '("scm" "sld" "ss")))
32
33(define (read-egg #!optional egg-file)
34 ;; Read EGG-FILE and return the structure inside.
35 (unless egg-file
36 (set! egg-file
37 (receive (_ _ dirs) (decompose-directory (current-directory))
38 (make-pathname (current-directory) (car (reverse dirs)) "egg"))))
39 (assert (file-exists? egg-file) "Can't find egg file" egg-file)
40 (assert (file-readable? egg-file) "Can't read egg file" egg-file)
41 (cons* `(egg-directory ,(pathname-directory egg-file))
42 `(egg-name ,(string->symbol (pathname-file egg-file)))
43 (with-input-from-file egg-file read)))
44
45(define (egg-directory) (alist-ref 'egg-directory (egg)))
46(define (egg-name) (car (alist-ref 'egg-name (egg))))
47(define (egg-components) (alist-ref 'components (egg)))
48(define (egg-csc-options)
49 (let ((opts (alist-walk (egg) 'component-options 'csc-options)))
50 (if opts (map ->string opts) '())))
51
52(define (source-of c)
53 ;; Find the source file of C and return it. If not found, error.
54 (cond
55 ((alist-ref 'source (cddr (find-component c)))
56 => (lambda (s)
57 (receive (dirs file ext) (decompose-pathname (->string (car s)))
58 (make-pathname (append (egg-directory)
59 (if (list? dirs) dirs (list dirs)))
60 file ext))))
61 (else
62 (let loop ((ext (source-extensions)))
63 (if (null? ext) #f
64 (let ((cand (make-pathname (egg-directory) c ext)))
65 (if (file-exists? cand) cand
66 (loop (cdr ext)))))))))
67
68(define (output-of c)
69 ;; Return the output file of C. It's okay if it doesn't exist.
70 (make-pathname (append (egg-directory) (list (build-dir)))
71 (->string c)
72 (case (car (find-component c))
73 ((extension) "so")
74 ((program)))))
75
76(define (find-component name)
77 (find (lambda (c) (eq? name (cadr c)))
78 (alist-ref 'components (egg))))
79
80(define (dependency-graph)
81 ;; Build a dependency graph from the egg.
82 (define (component->deps c)
83 (let* ((c-name (cadr c))
84 (c-info (cddr c))
85 (c-deps (or (alist-ref 'component-dependencies c-info) '()))
86 (s-deps (or (alist-ref 'source-dependencies c-info) '())))
87 (if (null? (append c-deps s-deps))
88 `(,c-name ,c-name)
89 `(,c-name . ,(cons c-name
90 (append c-deps
91 (map ->string s-deps)))))))
92 (filter-map component->deps (egg-components)))
93
94(define (alist-walk lis . keys)
95 (if (null? keys)
96 lis
97 (let ((kv (assoc (car keys) lis)))
98 (cond
99 ((not kv) #f)
100 ((atom? (cdr kv))
101 (and (null? (cdr keys)) ; this shouldn't error...
102 (cdr kv)))
103 ((list? (cdr kv))
104 (apply alist-walk (cdr kv) (cdr keys)))))))
105
106(define (string-join ss)
107 (string-intersperse ss " "))
108
109(define (find-executable name)
110 (let loop ((path (string-split (get-environment-variable "PATH") ":")))
111 (cond
112 ;; If no executable is found, return just the name. Another option would
113 ;; be to error out if there isn't an executable here ...
114 ((null? path) name)
115 ((and (directory-exists? (car path))
116 (member name (directory (car path) 'with-dotfiles)))
117 (make-pathname (car path) name))
118 (else (loop (cdr path))))))
119
120(define (rule c)
121 (let ((deps (alist-ref c (dependency-graph))))
122 (sprintf "~a: ~a $(BUILD)\n\t~a\n\t-mv ~a.import.scm $(BUILD)/"
123 (output-of c)
124 (string-join (cons (source-of (car deps))
125 (map output-of (cdr deps))))
126 "$(CSC) $(CSC_OPTIONS) $(CSC_OPTIONS_EXTRA) $< -o $@"
127 c)))
128
129(define (emit-makefile egg-file)
130 (parameterize ((egg (read-egg egg-file)))
131 (print "# Automatically generated by scramble") (newline)
132 (print "NAME = " (egg-name))
133 (print "CSC = " (find-executable "csc"))
134 (print "CSC_OPTIONS = " (string-join csc-options))
135 (print "CSC_OPTIONS_EXTRA = " (string-join (egg-csc-options)))
136 (print "CSI = " (find-executable "csi"))
137 (print "BUILD = $(PWD)/" (build-dir))
138 (print "TESTS = $(PWD)/tests")
139 (print "TEST_ENV = env BUILD=$(BUILD) TESTS=$(TESTS)")
140 (newline)
141 (print ".PHONY: all test clean install uninstall")
142 (print "all: " (string-join (map (o source-of car) (dependency-graph))))
143 (print "test: build"
144 "\n\t" "cd $(BUILD) && "
145 "$(TEST_ENV) $(CSI) -setup-mode -s $(TESTS)/run.scm $(NAME)")
146 (print "clean:\n\t-rm -rf $(BUILD)")
147 (print "install:\n\tchicken-install -s")
148 (print "uninstall:\n\tchicken-uninstall -s")
149 (newline) (print "# " (egg-name)) (newline)
150 (print "$(BUILD):\n\t-mkdir $(BUILD)")
151 (for-each (o print rule cadr) (egg-components))
152 ))