118 lines
4.7 KiB
Racket
118 lines
4.7 KiB
Racket
#lang scheme/unit
|
|
|
|
(require "make-sig.ss")
|
|
|
|
(import)
|
|
(export make^)
|
|
|
|
(define make-print-checking (make-parameter #t))
|
|
(define make-print-dep-no-line (make-parameter #t))
|
|
(define make-print-reasons (make-parameter #t))
|
|
(define make-notify-handler (make-parameter void))
|
|
|
|
(define-struct line (targets ; (list-of string)
|
|
dependencies ; (list-of string)
|
|
command)) ; (union thunk #f)
|
|
(define-struct (exn:fail:make exn:fail) (target orig-exn))
|
|
|
|
;; check-spec : TST -> (non-empty-list-of line)
|
|
;; throws an error on bad input
|
|
(define (spec->lines spec)
|
|
(define (->strings xs)
|
|
(map (lambda (x) (if (path? x) (path->string x) x)) xs))
|
|
(define (err s p) (error 'make/proc "~a: ~e" s p))
|
|
(unless (and (list? spec) (pair? spec))
|
|
(err "specification is not a non-empty list" spec))
|
|
(for/list ([line spec])
|
|
(unless (and (list? line) (<= 2 (length line) 3))
|
|
(err "line is not a list with 2 or 3 parts" line))
|
|
(let* ([name (car line)]
|
|
[tgts (if (list? name) name (list name))]
|
|
[deps (cadr line)]
|
|
[thunk (and (pair? (cddr line)) (caddr line))])
|
|
(define (err s p) (error 'make/proc "~a: ~e for line: ~a" s p name))
|
|
(unless (andmap path-string? tgts)
|
|
(err "line does not start with a path/string or list of paths/strings"
|
|
line))
|
|
(unless (list? deps) (err "second part of line is not a list" deps))
|
|
(for ([dep deps])
|
|
(unless (path-string? dep)
|
|
(err "dependency item is not a path/string" dep)))
|
|
(unless (or (not thunk)
|
|
(and (procedure? thunk) (procedure-arity-includes? thunk 0)))
|
|
(err "command part of line is not a thunk" thunk))
|
|
(make-line (->strings tgts) (->strings deps) thunk))))
|
|
|
|
;; (union path-string (vector-of path-string) (list-of path-string))
|
|
;; -> (list-of string)
|
|
;; throws an error on bad input
|
|
(define (argv->args x)
|
|
(let ([args (cond [(list? x) x]
|
|
[(vector? x) (vector->list x)]
|
|
[else (list x)])])
|
|
(map (lambda (a)
|
|
(cond [(string? a) a]
|
|
[(path? a) (path->string a)]
|
|
[else (raise-type-error
|
|
'make/proc "path/string or path/string vector or list"
|
|
x)]))
|
|
args)))
|
|
|
|
;; path-date : path-string -> (union integer #f)
|
|
(define (path-date p)
|
|
(and (or (directory-exists? p) (file-exists? p))
|
|
(file-or-directory-modify-seconds p)))
|
|
|
|
;; make/proc :
|
|
;; spec (union path-string (vector-of path-string) (list-of path-string))
|
|
;; -> void
|
|
;; effect : make, according to spec and argv. See docs for details
|
|
(define (make/proc spec [argv '()])
|
|
(define made null)
|
|
(define lines (spec->lines spec))
|
|
(define args (argv->args argv))
|
|
(define (make-file s indent)
|
|
(define line
|
|
(findf (lambda (line)
|
|
(ormap (lambda (s1) (string=? s s1)) (line-targets line)))
|
|
lines))
|
|
(define date (path-date s))
|
|
(when (and (make-print-checking) (or line (make-print-dep-no-line)))
|
|
(printf "make: ~achecking ~a\n" indent s)
|
|
(flush-output))
|
|
(if (not line)
|
|
(unless date (error 'make "don't know how to make ~a" s))
|
|
(let* ([deps (line-dependencies line)]
|
|
[command (line-command line)]
|
|
[indent+ (string-append indent " ")]
|
|
[dep-dates (for/list ([d deps])
|
|
(make-file d indent+)
|
|
(or (path-date d)
|
|
(error 'make "dependancy ~a was not made\n" d)))]
|
|
[reason (or (not date)
|
|
(ormap (lambda (dep ddate) (and (> ddate date) dep))
|
|
deps dep-dates))])
|
|
(when (and reason command)
|
|
(set! made (cons s made))
|
|
((make-notify-handler) s)
|
|
(printf "make: ~amaking ~a~a\n"
|
|
(if (make-print-checking) indent "")
|
|
s
|
|
(cond [(not (make-print-reasons)) ""]
|
|
[(not date) (format " because ~a does not exist" s)]
|
|
[else (format " because ~a changed" reason)]))
|
|
(flush-output)
|
|
(with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(raise (make-exn:fail:make
|
|
(format "make: failed to make ~a; ~a"
|
|
s (exn-message exn))
|
|
(exn-continuation-marks exn)
|
|
(line-targets line)
|
|
exn)))])
|
|
(command))))))
|
|
(for ([f (if (null? args) (list (car (line-targets (car lines)))) args)])
|
|
(make-file f ""))
|
|
(for ([item (reverse made)]) (printf "make: made ~a\n" item))
|
|
(flush-output))
|