Removed rash integration again and backported raco call.
This commit is contained in:
@@ -1,23 +1,25 @@
|
||||
#lang racket/base
|
||||
|
||||
(require (except-in racket #%module-begin)
|
||||
(only-in racket/base [#%module-begin racket-module-begin])
|
||||
(for-syntax racket/base)
|
||||
(require racket
|
||||
(for-syntax racket/base
|
||||
racket/list
|
||||
racket/string
|
||||
syntax/parse)
|
||||
"private/commands.rkt"
|
||||
"private/engine.rkt"
|
||||
git-cli
|
||||
package-zipper
|
||||
net/sendurl
|
||||
racket/string
|
||||
)
|
||||
racket/string)
|
||||
|
||||
(provide (all-from-out racket)
|
||||
(rename-out [makefile-module-begin #%module-begin])
|
||||
(provide makefile
|
||||
target
|
||||
deps
|
||||
phony
|
||||
default-target
|
||||
make
|
||||
current-makefile-prefix
|
||||
makefile-targets
|
||||
refresh-makefile
|
||||
run
|
||||
raco
|
||||
@@ -33,148 +35,195 @@
|
||||
(all-from-out git-cli)
|
||||
(all-from-out package-zipper)
|
||||
(all-from-out net/sendurl)
|
||||
(all-from-out racket/string)
|
||||
)
|
||||
(all-from-out racket/string))
|
||||
|
||||
|
||||
;; The makefile module currently loaded in this Racket process. Keeping only
|
||||
;; its source path is enough: target state lives in the engine and is rebuilt
|
||||
;; when the makefile module is evaluated again.
|
||||
(define loaded-makefile #f)
|
||||
|
||||
(define (remember-makefile! path)
|
||||
(set! loaded-makefile path)
|
||||
(when path
|
||||
(set! loaded-makefile path))
|
||||
(void))
|
||||
|
||||
(define-for-syntax (remember-source-form stx)
|
||||
(define source (syntax-source stx))
|
||||
(if (path? source)
|
||||
#`(remember-makefile! (string->path #,(path->string source)))
|
||||
#'(void)))
|
||||
|
||||
(define (refresh-makefile)
|
||||
(unless loaded-makefile
|
||||
(error 'refresh-makefile "no racket-makefile has been loaded"))
|
||||
(error 'refresh-makefile "no makefile definition has been evaluated"))
|
||||
|
||||
(define source loaded-makefile)
|
||||
(define directory (or (path-only source) (current-directory)))
|
||||
;; Load the edited makefile as a fresh module in the same namespace. Its
|
||||
;; required modules therefore reuse their existing module instances, while
|
||||
;; the makefile body itself runs again and re-registers all targets.
|
||||
(define refresh-source
|
||||
(make-temporary-file "racket-makefile-refresh~a.rkt" #f directory))
|
||||
|
||||
(copy-file source refresh-source #t)
|
||||
;; With #lang racket, main.rkt is only required and our custom module-begin
|
||||
;; does not run. Reset explicitly so removed/renamed targets disappear too.
|
||||
(reset-makefile!)
|
||||
(reset-makefiles!)
|
||||
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(λ ()
|
||||
(dynamic-require refresh-source #f))
|
||||
(lambda ()
|
||||
;; Loading the temporary copy also runs remember-makefile!. Keep the
|
||||
;; original source as the file to use for the next refresh.
|
||||
(λ ()
|
||||
(set! loaded-makefile source)
|
||||
(delete-file refresh-source)))
|
||||
(void))
|
||||
|
||||
;; For target declarations we want a bound identifier to remain an ordinary
|
||||
;; Racket expression. This makes generated targets such as (target obj ...)
|
||||
;; possible inside a for loop. An unbound identifier is a literal target name.
|
||||
(define-for-syntax (literal-name-or-expression stx)
|
||||
(if (and (identifier? stx)
|
||||
(not (identifier-binding stx)))
|
||||
(datum->syntax stx `(quote ,(syntax-e stx)) stx stx)
|
||||
stx))
|
||||
|
||||
;; For interactive make invocations a bare identifier is always a literal
|
||||
;; target name. Thus (make compile) means the target named "compile" even if
|
||||
;; Racket happens to provide a binding named compile.
|
||||
(define-for-syntax (literal-make-name stx)
|
||||
(if (identifier? stx)
|
||||
(datum->syntax stx `(quote ,(syntax-e stx)) stx stx)
|
||||
stx))
|
||||
|
||||
(define-syntax (makefile-module-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ form ...)
|
||||
#'(racket-module-begin
|
||||
(reset-makefile!)
|
||||
(remember-makefile!
|
||||
(variable-reference->module-source (#%variable-reference)))
|
||||
form ...
|
||||
;; Re-export make so that `racket -t Makefile.rkt -e "(make all)"`
|
||||
;; imports the make form into the command-line evaluation namespace.
|
||||
(provide make refresh-makefile quote #%top-interaction #%app #%datum #%top))]))
|
||||
|
||||
(define-syntax (deps stx)
|
||||
(raise-syntax-error 'deps "only valid as the dependency clause of target" stx))
|
||||
|
||||
(define-syntax (target stx)
|
||||
(syntax-case stx (deps)
|
||||
[(_ name (deps dependency ...) body ...)
|
||||
(with-syntax ([target-name (literal-name-or-expression #'name)]
|
||||
[(target-dependency ...)
|
||||
(map literal-name-or-expression
|
||||
(syntax->list #'(dependency ...)))])
|
||||
(with-syntax ([remember-source (remember-source-form stx)])
|
||||
#'(begin
|
||||
remember-source
|
||||
(register-target!
|
||||
target-name
|
||||
(list target-dependency ...)
|
||||
(lambda () body ... (void))))))]
|
||||
[(_ name body ...)
|
||||
(with-syntax ([target-name (literal-name-or-expression #'name)]
|
||||
[remember-source (remember-source-form stx)])
|
||||
#'(begin
|
||||
remember-source
|
||||
(register-target!
|
||||
target-name
|
||||
'()
|
||||
(lambda () body ... (void)))))]))
|
||||
|
||||
(define-syntax (phony stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name ...)
|
||||
(with-syntax ([(target-name ...)
|
||||
(map literal-name-or-expression
|
||||
(syntax->list #'(name ...)))]
|
||||
[remember-source (remember-source-form stx)])
|
||||
#'(begin
|
||||
remember-source
|
||||
(mark-phony! target-name ...)))]))
|
||||
|
||||
(define-syntax (default-target stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
(with-syntax ([target-name (literal-name-or-expression #'name)]
|
||||
[remember-source (remember-source-form stx)])
|
||||
#'(begin
|
||||
remember-source
|
||||
(set-default-target! target-name)))]))
|
||||
|
||||
(define-syntax (make stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name ...)
|
||||
(with-syntax ([(target-name ...)
|
||||
(map literal-make-name
|
||||
(syntax->list #'(name ...)))])
|
||||
#'(make-targets! target-name ...))]))
|
||||
(define (make . names)
|
||||
(apply make-targets! names))
|
||||
|
||||
(define-syntax $target
|
||||
(syntax-id-rules ()
|
||||
[$target
|
||||
(or (current-target)
|
||||
(error '$target "$target is only available while a target recipe is running"))]))
|
||||
(error '$target "$target is only available while a target procedure is running"))]))
|
||||
|
||||
(define-syntax $deps
|
||||
(syntax-id-rules ()
|
||||
[$deps
|
||||
(or (current-dependencies)
|
||||
(error '$deps "$deps is only available while a target recipe is running"))]))
|
||||
(error '$deps "$deps is only available while a target procedure is running"))]))
|
||||
|
||||
(define-syntax $<
|
||||
(syntax-id-rules ()
|
||||
[$<
|
||||
(or (current-first-dependency)
|
||||
(error '$< "$< is only available while a target recipe with dependencies is running"))]))
|
||||
(error '$< "$< is only available while a target procedure with dependencies is running"))]))
|
||||
|
||||
(define-syntax (target stx)
|
||||
(raise-syntax-error 'target "only valid inside makefile" stx))
|
||||
|
||||
(define-syntax (deps stx)
|
||||
(raise-syntax-error 'deps "only valid inside a target clause in makefile" stx))
|
||||
|
||||
(define-syntax (phony stx)
|
||||
(raise-syntax-error 'phony "only valid inside makefile" stx))
|
||||
|
||||
(define-syntax (default-target stx)
|
||||
(raise-syntax-error 'default-target "only valid inside makefile" stx))
|
||||
|
||||
(begin-for-syntax
|
||||
(struct target-spec (name-datum name-expression dependencies body source) #:transparent)
|
||||
|
||||
(define (literal-name-datum stx who)
|
||||
(syntax-parse stx
|
||||
[id:id
|
||||
(syntax-e #'id)]
|
||||
[s:str
|
||||
(syntax-e #'s)]
|
||||
[((~datum quote) value)
|
||||
(define datum (syntax-e #'value))
|
||||
(unless (or (symbol? datum) (string? datum) (path? datum))
|
||||
(raise-syntax-error who "expected a symbol, string, or path target name" stx))
|
||||
datum]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
who
|
||||
"target and makefile names must be literal identifiers, strings, paths, or quoted symbols"
|
||||
stx)]))
|
||||
|
||||
(define (literal-expression stx who)
|
||||
(define datum (literal-name-datum stx who))
|
||||
#`(quote #,datum))
|
||||
|
||||
(define (dependency-expression stx)
|
||||
(if (and (identifier? stx)
|
||||
(not (identifier-binding stx)))
|
||||
#`(quote #,(syntax-e stx))
|
||||
stx))
|
||||
|
||||
(define (procedure-identifier context prefix target)
|
||||
(define name
|
||||
(string->symbol
|
||||
(format "makefile-target-~a-~a" prefix target)))
|
||||
(datum->syntax context name context context))
|
||||
|
||||
(define (parse-target clause)
|
||||
(syntax-parse clause
|
||||
#:datum-literals (target deps)
|
||||
[(target name (deps dependency ...) body ...)
|
||||
(define datum (literal-name-datum #'name 'target))
|
||||
(target-spec datum
|
||||
(literal-expression #'name 'target)
|
||||
(map dependency-expression
|
||||
(syntax->list #'(dependency ...)))
|
||||
(syntax->list #'(body ...))
|
||||
clause)]
|
||||
[(target name body ...)
|
||||
(define datum (literal-name-datum #'name 'target))
|
||||
(target-spec datum
|
||||
(literal-expression #'name 'target)
|
||||
'()
|
||||
(syntax->list #'(body ...))
|
||||
clause)]))
|
||||
)
|
||||
|
||||
(define-syntax (makefile stx)
|
||||
(syntax-parse stx
|
||||
#:datum-literals (target phony default-target)
|
||||
[(_ prefix clause ...)
|
||||
(define prefix-datum (literal-name-datum #'prefix 'makefile))
|
||||
(define prefix-expression #`(quote #,prefix-datum))
|
||||
(define clauses (syntax->list #'(clause ...)))
|
||||
|
||||
(define targets '())
|
||||
(define phony-forms '())
|
||||
(define default-forms '())
|
||||
|
||||
(for ([clause (in-list clauses)])
|
||||
(syntax-parse clause
|
||||
#:datum-literals (target phony default-target)
|
||||
[(target . _)
|
||||
(set! targets (append targets (list (parse-target clause))))]
|
||||
[(phony name ...)
|
||||
(define names
|
||||
(for/list ([name (in-list (syntax->list #'(name ...)))])
|
||||
(literal-expression name 'phony)))
|
||||
(set! phony-forms
|
||||
(append phony-forms
|
||||
(list #`(mark-phony! #,prefix-expression #,@names))))]
|
||||
[(default-target name)
|
||||
(define name-expression (literal-expression #'name 'default-target))
|
||||
(set! default-forms
|
||||
(append default-forms
|
||||
(list #`(set-default-target!
|
||||
#,prefix-expression
|
||||
#,name-expression))))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'makefile
|
||||
"expected target, phony, or default-target clause"
|
||||
clause)]))
|
||||
|
||||
(define target-definitions
|
||||
(for/list ([spec (in-list targets)])
|
||||
(define proc-id
|
||||
(procedure-identifier stx prefix-datum (target-spec-name-datum spec)))
|
||||
(define name-expression (target-spec-name-expression spec))
|
||||
(define dependencies (target-spec-dependencies spec))
|
||||
(define body (target-spec-body spec))
|
||||
#`(begin
|
||||
(define (#,proc-id)
|
||||
(call-target-procedure
|
||||
#,prefix-expression
|
||||
#,name-expression
|
||||
(λ ()
|
||||
#,@body
|
||||
(void))))
|
||||
(register-target!
|
||||
#,prefix-expression
|
||||
#,name-expression
|
||||
(list #,@dependencies)
|
||||
#,proc-id))))
|
||||
|
||||
(define source (syntax-source stx))
|
||||
(define remember-source
|
||||
(if (path? source)
|
||||
#`(remember-makefile! (string->path #,(path->string source)))
|
||||
#'(void)))
|
||||
|
||||
#`(begin
|
||||
#,remember-source
|
||||
(begin-makefile! #,prefix-expression)
|
||||
#,@target-definitions
|
||||
#,@phony-forms
|
||||
#,@default-forms
|
||||
;; The last makefile definition evaluated is the active makefile.
|
||||
(current-makefile-prefix #,prefix-expression)
|
||||
(void))]))
|
||||
|
||||
Reference in New Issue
Block a user