source: project/build/build.scm @ 2488

Last change on this file since 2488 was 2488, checked in by felix winkelmann, 14 years ago

various updates, documentation update for chicken-setup

File size: 11.6 KB
Line 
1;;;; build.scm
2
3
4(use (srfi 1) posix utils)
5
6
7#+(not csi)
8(declare
9  (export make/proc run:run run:run/string run:run/lines run:execute quit path
10          build build-clear depends actions build-dump on build:*output-file*
11          prefix suffix normalize build:*actions* message build:*context-prefix*
12          build:*subdirs* in-context subdirs with-cwd normalize-path
13          build:clean-on-error ->mode ->boolean notfile color-codes) ) 
14
15
16(define *verbose* #f)
17(define *VERBOSE* #f)
18(define *dry-run* #f)
19(define *dependencies* (make-hash-table string=?))
20(define *variables* (make-hash-table string=?))
21(define build:*actions* (make-hash-table string=?))
22(define build:*output-file* #f)
23(define build:*context-prefix* #f)
24(define build:*subdirs* '())
25(define *pseudotargets* '())
26
27
28;;; Error handling
29
30(define (quit fstr . args)
31  (abort
32   (make-composite-condition
33    (make-property-condition 'exn 'message (sprintf "~?~%" fstr args) 'arguments '())
34    (make-property-condition 'quit 'status 1) ) ) )
35
36
37;;; Verbosity and output
38
39(define *tty* 
40  (and (##sys#tty-port? (current-output-port)) 
41       (not (equal? (getenv "EMACS") "t"))
42       (not (equal? (getenv "TERM") "dumb"))))
43
44(define *info-message-escape* (if *tty* "\x1b[0m\x1b[2m" ""))
45(define *target-message-escape* (if *tty* "\x1b[0m\x1b[32m" ""))
46(define *error-message-escape* (if *tty* "\x1b[0m\x1b[31m" ""))
47(define *command-message-escape* (if *tty* "\x1b[0m\x1b[33m" ""))
48(define *reset-escape* (if *tty* "\x1b[0m" ""))
49
50(define (message fstr . args)
51  (printf "~a* ~?~a~%" *info-message-escape* fstr args *reset-escape*) )
52
53(define (target-message fstr . args)
54  (printf "~a~?~a~%" *target-message-escape* fstr args *reset-escape*) )
55
56(define (command-message fstr . args)
57  (printf "~a  ~?~a~%" *command-message-escape* fstr args *reset-escape*) )
58
59(define (color-codes alist)
60  (when *tty*
61    (let loop ((alist alist))
62      (unless (null? alist)
63        (match (car alist)
64          (('info col) (set! *info-message-escape* col))
65          (('target col) (set! *target-message-escape* col))
66          (('error col) (set! *error-message-escape* col))
67          (('command col) (set! *command-message-escape* col))
68          (else (error 'color-codes "invalid color code" (car alist))) )
69        (loop (cdr alist)) ) ) ) )
70
71
72;;; make-code stolen from PLT
73
74(define (find-matching-line str spec)
75  (let ([match? (lambda (s) (string=? s str))])
76    (let loop ([lines spec])
77      (cond
78       [(null? lines) #f]
79       [else (let* ([line (car lines)]
80                    [names (if (string? (car line))
81                               (list (car line))
82                               (car line))])
83               (if (ormap match? names)
84                   line
85                   (loop (cdr lines))))]))))
86
87(define (form-error s p) (quit "~a: ~s" s p))
88(define (line-error s p n) (quit "~a: ~s in line ~a" s p))
89
90(define (check-spec spec)
91  (and (or (list? spec) (form-error "specification is not a list" spec))
92       (or (pair? spec) (form-error "specification is an empty list" spec))
93       (andmap
94        (lambda (line)
95          (and (or (and (list? line) (<= 2 (length line) 3))
96                   (form-error "list is not a list with 2 or 3 parts" line))
97               (or (or (string? (car line))
98                       (and (list? (car line))
99                            (andmap string? (car line))))
100                   (form-error "line does not start with a string or list of strings" line))
101               (let ([name (car line)])
102                 (or (list? (cadr line))
103                     (line-error "second part of line is not a list" (cadr line) name)
104                     (andmap (lambda (dep)
105                               (or (string? dep)
106                                   (form-error "dependency item is not a string" dep)))
107                             (cadr line)))
108                 (or (null? (cddr line))
109                     (procedure? (caddr line))
110                     (line-error "command part of line is not a thunk" (caddr line) name)))))
111        spec)))
112
113(define (check-argv argv)
114  (or (string? argv)
115      (and (vector? argv)
116           (andmap string? (vector->list argv)))
117      (error "argument is not a string or string vector" argv)))
118
119(define (make/proc/helper spec argv)
120  (check-spec spec)
121  (check-argv argv)
122  (letrec ([made '()]
123           [exn? (condition-predicate 'exn)]
124           [exn-message (condition-property-accessor 'exn 'message)]
125           [make-file
126            (lambda (s indent)
127              (let ([line (find-matching-line s spec)]
128                    [date (and (not (member s *pseudotargets*))
129                               (file-exists? s)
130                               (file-modification-time s))])
131
132                (when *VERBOSE*
133                  (message "~achecking ~a" indent s))
134
135                (if line
136                    (let ([deps (cadr line)])
137                      (for-each (let ([new-indent (string-append " " indent)])
138                                  (lambda (d) (make-file d new-indent)))
139                                deps)
140                      (let ([reason
141                             (or (not date)
142                                 (ormap (lambda (dep)
143                                          (cond ((not *dry-run*)
144                                                 (unless (file-exists? dep)
145                                                   (quit "dependancy ~a was not made~%" dep))
146                                                 (and (> (file-modification-time dep) date)
147                                                      dep))
148                                                (else #f) ) )
149                                        deps))])
150                        (when reason
151                          (let ([l (cddr line)])
152                            (unless (null? l)
153                              (set! made (cons s made))
154                              (when *VERBOSE*
155                                (message "~amaking ~a~a"
156                                        indent
157                                        s
158                                        (cond
159                                         [(not date)
160                                          (string-append " because " s " does not exist")]
161                                         [(string? reason)
162                                          (string-append " because " reason " changed")]
163                                         [else
164                                          (string-append (sprintf " just because (reason: ~a date: ~a)" reason date))])))
165                              ((car l)))))))
166                    (when (and (not date) (not *dry-run*))
167                      (quit "don't know how to make ~a" s)))))])
168    (cond
169     [(string? argv) (make-file argv "")]
170     [(equal? argv '#()) (make-file (caar spec) "")]
171     [else (for-each (lambda (f) (make-file f "")) (vector->list argv))]) ) )
172
173(define make/proc
174  (case-lambda
175   [(spec) (make/proc/helper spec '#())]
176   [(spec argv) (make/proc/helper spec argv)]))
177
178(define (notfile . ss)
179  (set! *pseudotargets* (lset-union string=? *pseudotargets* (normalize ss)) ))
180
181
182;;; Run subcommands
183
184(define (run:execute exps runner)
185  (for-each
186   (lambda (exp)
187     (let ((cmd (string-intersperse (map ->string (flatten exps)))))
188       (when *verbose* (command-message "~A" cmd))
189       (unless *dry-run* (runner cmd) ) ) )
190   exps) )
191
192(define (run:run cmd)
193  (if build:*output-file*
194      (write-line cmd build:*output-file*)
195      (let ((s (system cmd)))
196        (unless (zero? s)
197          (quit (sprintf "invocation of command failed with non-zero exit-status ~a: ~a~%" s cmd) s) ) ) ) )
198
199(define run:run/string (cut with-input-from-pipe <> read-all))
200
201(define (run:run/lines cmd)
202  (string-split (run:run/string cmd) "\n") )
203
204
205;;; String and path helper functions
206
207(define (prefix dir . files)
208  (if (null? files)
209      (pathname-directory dir)
210      (let ((files2 (map (cut make-pathname dir <>) (normalize files))))
211        (if (or (pair? (cdr files)) (pair? (car files)))
212            files2
213            (car files2) ) ) ) )
214
215(define (suffix suf . files)
216  (if (null? files)
217      (pathname-extension suf)
218      (let ((files2 (map (cut pathname-replace-extension <> suf) (normalize files))))
219        (if (or (pair? (cdr files)) (pair? (car files)))
220            files2
221            (car files2) ) ) ) )
222
223(define (normalize fs)
224  (delete-duplicates
225   (map ->string
226        (if (pair? fs)
227            (flatten fs)
228            (list fs) ) )
229   equal?) )
230
231(define path make-pathname)
232
233(define (->boolean x)
234  (cond ((equal? x "") #f)
235        (else x) ) )
236
237(define (->mode x)
238  (if (number? x)
239      (number->string x 8)
240      (->string x) ) )
241
242(define (with-cwd dir thunk)
243  (if (or (not dir) (equal? "." dir))
244      (thunk)
245      (let ((old #f))
246        (dynamic-wind
247            (lambda () (set! old (current-directory)))
248            (lambda ()
249              (when *verbose* (command-message "cd ~a" dir))
250              (change-directory dir)
251              (thunk) )
252            (lambda ()
253              (change-directory old)
254              (when *verbose* (command-message "cd ~a" old) ) ) ) ) ) )
255
256(define (normalize-path path)
257  (string-intersperse
258   (let loop ((p (string-split-fields "/" path infix:)))
259     (match p
260       (() '())
261       (("" "" . more) (loop more))
262       (("." . more) (loop more))
263       ((_ ".." . more) (loop more))
264       ((x . more) (cons x (loop more))) ) )
265   "/") )
266
267(define (in-context file)
268  (cond ((member file *pseudotargets*) file)
269        ((and build:*context-prefix* (not (equal? "." build:*context-prefix*)))
270         (normalize-path (make-pathname build:*context-prefix* file)) )
271        (else file) ) )
272
273(define (run-in-context proc)
274  (if (and build:*context-prefix* (not (equal? "." build:*context-prefix*)))
275      (let ((p build:*context-prefix*))
276        (lambda args (with-cwd p (lambda () (apply proc args))))  )
277      proc) )
278
279
280;;; Build variables
281
282(define on 
283  (getter-with-setter
284   (lambda (name var #!optional (default ""))
285     (cond ((assq var (hash-table-ref/default *variables* name '())) => cadr)
286           (else default)) )
287   (lambda (names var val)
288     (for-each
289      (lambda (name)
290        (let ((a (hash-table-ref/default *variables* name #f)))
291          (cond ((not a) (hash-table-set! *variables* name (list (list var val))))
292                ((assq var a) => (lambda (p) (set-car! (cdr p) val)))
293                (else (hash-table-set! *variables* name (cons (list var val) a))) ) ) )
294      (normalize names) ) ) ) )
295
296
297;;; "Stateful" build interface
298
299(define (build-clear)
300  (set! *dependencies* (make-hash-table string=?)) 
301  (set! build:*actions* (make-hash-table string=?)) 
302  (set! *variables* (make-hash-table string=?)) )
303
304(define (depends target . deps)
305  (let ((deps (map in-context (normalize deps))))
306    (hash-table-update!
307     *dependencies* (in-context target)
308     (lambda (old) (lset-union string=? old deps))
309     (lambda () deps) ) ) )
310
311(define actions
312  (let ((doaction 
313          (lambda (name target proc)
314            (hash-table-update! *dependencies* target identity (constantly '()))
315            (hash-table-set! 
316             build:*actions* target 
317             (lambda (t . ds)
318               (target-message "~a\t~a" name t)
319               (apply proc t ds) ) ) ) ) )
320    (case-lambda
321     ((target proc) (doaction "build " (in-context target) (run-in-context proc)))
322     ((name target proc) (doaction name (in-context target) (run-in-context proc)) ) ) ))
323
324(define (build:clean-on-error t thunk)
325  (handle-exceptions ex
326      (begin
327        (when (file-exists? t)
328          (when *verbose* (message "deleting ~a" t))
329          (delete-file t) )
330        (abort ex) )
331    (thunk) ) )
332
333(define (build #!optional
334               (targets "all")
335               #!key
336               (verbose *verbose*) 
337               (dry-run *dry-run*) )
338  (fluid-let ((*verbose* verbose)
339              (*dry-run* dry-run) )
340    (make/proc
341     (map (match-lambda 
342            ((target . deps)
343             (list target deps
344                   (eval
345                    `(lambda ()
346                       (build:clean-on-error
347                        ',target
348                        (lambda ()
349                          (fluid-let ,(hash-table-ref/default *variables* target '())
350                            (apply
351                             (hash-table-ref/default 
352                              build:*actions* ',target 
353                              (lambda (t . _) (if ,*VERBOSE* (message "nothing to do for ~a" t))))
354                             ',target ',deps) ) ) ) ) ) ) ) )
355          (hash-table->alist *dependencies*) )
356     (list->vector (normalize targets)) ) ) )
357
358(define (build-dump #!optional (port (current-output-port)))
359  (with-output-to-port port
360    (lambda ()
361      (message "dependencies:")
362      (for-each show-dependencies (hash-table-keys *dependencies*))
363      (when (positive? (hash-table-size *variables*))
364        (message "variables:")
365        (hash-table-walk
366         *variables*
367         (lambda (v x)
368           (message "  ~s:" v)
369           (for-each (lambda (p) (message "    ~a\t-> ~s~%" (car p) (cadr p))) x))) ) ) ) )
370   
371(define (show-dependencies target)
372  (let ((i ""))
373    (let loop ((t target))
374      (message "~a~a ~a" i t (if (member t *pseudotargets*) "(p)" ""))
375      (fluid-let ((i (string-append i " ")))
376        (for-each loop (hash-table-ref/default *dependencies* t '())) ) ) ) )
377
378(define (check-dependencies)
379  (for-each
380   (lambda (target)
381     (let loop ((t target) (done '()))
382       (if (member t done)
383           (quit "target ~a has cyclic dependencies" t)
384           (let ((done (cons t done)))
385             (for-each (cut loop <> done) (hash-table-ref/default *dependencies* t '())) ) ) ) )
386   (hash-table-keys *dependencies*) ) )
387
388
389;;; Subdir handling
390
391(define (subdirs . subs)
392  (set! build:*subdirs* (append build:*subdirs* (normalize subs)) ))
Note: See TracBrowser for help on using the repository browser.