194 lines
7.8 KiB
Racket
194 lines
7.8 KiB
Racket
#lang typed/racket
|
|
|
|
(provide make/proc
|
|
argv
|
|
string-prefix?
|
|
string-suffix?
|
|
find-files-by-extension
|
|
t-rule
|
|
rules
|
|
;rule
|
|
implicit-rule
|
|
for/rules
|
|
path-string->string
|
|
path-string->path
|
|
path-append
|
|
regexp-case
|
|
dirname
|
|
underscore-extension
|
|
compile-zos
|
|
rkt->zo-dir
|
|
rkt->zo-file
|
|
make-collection
|
|
run
|
|
run!)
|
|
|
|
(require/typed make [make/proc (→ (Listof
|
|
(Pairof (U Path-String (Listof Path-String))
|
|
(Pairof (Listof Path-String)
|
|
(U Null
|
|
(List (-> Any))))))
|
|
(U String (Vectorof String) (Listof String))
|
|
Void)])
|
|
;(require/typed make/collection [make-collection (→ Any (Listof Path-String) (U String (Vectorof String)) Void)])
|
|
|
|
(require/typed srfi/13
|
|
[string-suffix? (->* (String String) (Integer Integer Integer Integer) Boolean)]
|
|
[string-prefix? (->* (String String) (Integer Integer Integer Integer) Boolean)])
|
|
|
|
(define (find-files-by-extension [ext : String])
|
|
(find-files (λ ([path : Path]) (string-suffix? ext (path->string path)))))
|
|
|
|
;(: drop-extension (→ Path-String * String String))
|
|
;(define (drop-extension path . exts)
|
|
; (map (λ () exts)
|
|
|
|
(define-type t-rule (Pairof (U Path-String (Listof Path-String))
|
|
(Pairof (Listof Path-String)
|
|
(U Null
|
|
(List (-> Any))))))
|
|
(: rules (→ (U t-rule (Listof t-rule)) * (Listof t-rule)))
|
|
(define (rules . rs)
|
|
(apply append (map (λ ([x : (U t-rule (Listof t-rule))])
|
|
(cond [(null? x) '()] ;; x = '() is an empty (Listof t-rule)
|
|
[(null? (cdr x)) x] ;; x = '([target dep maybe-proc]) is a (Listof t-rule) with just one element
|
|
[(null? (cadr x)) (list x)] ;; x = '[target () maybe-proc] is a t-rule with an empty list of dependencies
|
|
;; Below, either x = '[target (dep₁ . ?) maybe-proc] or x = '([target dep maybe-proc] [target dep maybe-proc])
|
|
[(null? (cdadr x)) (list x)] ;; x = '[target (dep₁ . ()) maybe-proc]
|
|
[(list? (cadadr x)) x] ;; x = '([target dep maybe-proc] [target (?) maybe-proc])
|
|
[else (list x)])) ; x = '[target (dep₁ dep₂ . ()) maybe-proc]
|
|
rs)))
|
|
|
|
#|
|
|
(define-syntax (rule stx)
|
|
(syntax-case stx ()
|
|
[(_ (target ...) (depend ...) body0 . body)
|
|
#'(list (list target ...)
|
|
(list depend ...)
|
|
(λ () body0 . body))]
|
|
[(_ (target ...) (depend ...))
|
|
#'(list (list target ...)
|
|
(list depend ...))]))
|
|
|#
|
|
|
|
(define-syntax-rule (implicit-rule (arg ...) (target ...) (depend ...) body ...)
|
|
(λ ([arg : Path] ...)
|
|
(list (list target ...)
|
|
(list depend ...)
|
|
(λ () body ...))))
|
|
|
|
(define-syntax-rule (for/rules ([arg files] ...) (target ...) (depend ...) body ...)
|
|
(map (implicit-rule (arg ...) (target ...) (depend ...) body ...) files ...))
|
|
|
|
(: path-string->string (→ Path-String String))
|
|
(define (path-string->string ps)
|
|
(if (string? ps)
|
|
ps
|
|
(path->string ps)))
|
|
|
|
(: path-string->path (→ Path-String Path))
|
|
(define (path-string->path ps)
|
|
(if (string? ps)
|
|
(string->path ps)
|
|
ps))
|
|
|
|
(: path-append (→ Path-String Path-String Path))
|
|
(define (path-append a b)
|
|
(string->path (string-append (path-string->string a)
|
|
(path-string->string b))))
|
|
|
|
(define-syntax-rule (regexp-case input [pattern replacement] ...)
|
|
(let ([input-cache input]) ;; TODO: should also cache the patterns, but lazily.
|
|
(cond
|
|
[(regexp-match pattern input-cache) (regexp-replace pattern input-cache replacement)]
|
|
...
|
|
[else input-cache])))
|
|
|
|
(: dirname (→ Path Path))
|
|
(define (dirname p)
|
|
(let-values ([(base name must-be-dir?) (split-path p)])
|
|
(case base
|
|
['relative (build-path 'same)] ;; If the path is "..", then this is wrong.
|
|
['#f (error (format "Can't get parent directory of ~a" p))]
|
|
[else base])))
|
|
|
|
(: underscore-extension (→ Path-String String * Path))
|
|
(define (underscore-extension path . ext)
|
|
(if (null? ext)
|
|
(path-string->path path)
|
|
(let ([p (path-string->string path)]
|
|
[e (path-string->string (car ext))])
|
|
(if (string-suffix? (car ext) p)
|
|
(let* ([pos (- (string-length p) (string-length e))]
|
|
[left (substring p 0 pos)])
|
|
(string->path (string-append left (string-replace e "." "_"))))
|
|
(apply underscore-extension path (cdr ext))))))
|
|
|
|
;; TODO: do pattern-matching on paths, with (match) ?
|
|
|
|
(define (argv)
|
|
(let ([argv (current-command-line-arguments)])
|
|
(if (= (vector-length argv) 0)
|
|
#("zo")
|
|
argv)))
|
|
|
|
;; make-collection from /usr/local/racket-6.2.900.6/share/pkgs/make/collection-unit.rkt
|
|
(require/typed compiler/compiler [compile-zos (->* (Any) (#:module? Any #:verbose? Any) (→ (Listof Path-String) (U Path-String #f 'auto) Void))])
|
|
(require/typed dynext/file [append-zo-suffix (→ Path-String Path)])
|
|
|
|
(: cache (∀ (T) (→ (→ T) (→ T))))
|
|
(define (cache producer)
|
|
(let ([cache : (U False (List T)) #f]) ;; Use (List T) instead of T, so that if the producer returns #f, we don't call it each time.
|
|
(λ ()
|
|
(let ([c cache]) ;; since cache is mutated by set!, occurrence typing won't work on it, so we need to take a copy.
|
|
(if c
|
|
(car c)
|
|
(let ((producer-result (producer)))
|
|
(set! cache (list producer-result))
|
|
producer-result))))))
|
|
|
|
(: rkt->zo-dir (→ Path-String Path))
|
|
(define (rkt->zo-dir src-file)
|
|
(simplify-path (build-path src-file 'up "compiled") #f))
|
|
|
|
(: rkt->zo-file (→ Path-String Path))
|
|
(define (rkt->zo-file src-file)
|
|
(build-path (rkt->zo-dir src-file) (append-zo-suffix (assert (file-name-from-path src-file)))))
|
|
|
|
(: make-collection (→ Any (Listof Path-String) (U String (Vectorof String)) Void))
|
|
(define (make-collection collection-name collection-files argv)
|
|
(printf "building collection ~a: ~a\n" collection-name collection-files)
|
|
(let* ([zo-compiler (cache (λ () (compile-zos #f)))]
|
|
[src-dir (current-directory)]
|
|
[rkts (sort collection-files
|
|
(lambda ([a : Path] [b : Path])
|
|
(string-ci<? (path->string a) (path->string b))))]
|
|
[zos (map (lambda ([rkt : Path-String])
|
|
(rkt->zo-file rkt))
|
|
rkts)]
|
|
[rkt->zo-list
|
|
(map (lambda ([rkt : Path-String] [zo : Path])
|
|
`(,zo (,rkt)
|
|
,(lambda ()
|
|
(let ([dest (rkt->zo-dir rkt)])
|
|
(unless (directory-exists? dest) (make-directory dest))
|
|
((zo-compiler) (list rkt) dest)))))
|
|
rkts zos)])
|
|
(make/proc (append `(("zo" ,zos)) rkt->zo-list) argv)))
|
|
|
|
(: run (→ (U Path-String (Pairof Path-String (Listof (U Path-String Bytes)))) [#:set-pwd? Any] (U Path-String Bytes) * Boolean))
|
|
(define (run arg0 #:set-pwd? [set-pwd? #f] . args)
|
|
(if (list? arg0)
|
|
(apply run arg0)
|
|
(begin
|
|
(displayln (string-append (string-join (cons (path-string->string arg0) (map (λ (x) (format "~a" x)) args)) " ")))
|
|
(display "\033[1;34m")
|
|
(flush-output)
|
|
(let ((result (apply system* arg0 args)))
|
|
(display "\033[m")
|
|
(flush-output)
|
|
(unless result
|
|
(raise "Command failed."))
|
|
result))))
|
|
|
|
(define-syntax-rule (run! . rest) (let () (run . rest) (values))) |