makefile-targets and some other meta info functions added
This commit is contained in:
@@ -1,9 +1,10 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket
|
||||
racket/splicing
|
||||
racket/stxparam
|
||||
(for-syntax racket/base
|
||||
racket/list
|
||||
racket/string
|
||||
racket/stxparam
|
||||
syntax/parse)
|
||||
"private/commands.rkt"
|
||||
"private/engine.rkt"
|
||||
@@ -19,7 +20,10 @@
|
||||
default-target
|
||||
make
|
||||
current-makefile-prefix
|
||||
makefile-prefixes
|
||||
makefile-targets
|
||||
makefile-target-exists?
|
||||
makefile-target-procedure
|
||||
refresh-makefile
|
||||
run
|
||||
raco
|
||||
@@ -86,47 +90,37 @@
|
||||
(or (current-first-dependency)
|
||||
(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))
|
||||
(define-syntax-parameter makefile-prefix
|
||||
(λ (stx)
|
||||
(raise-syntax-error 'racket-makefile "only valid inside makefile" stx)))
|
||||
|
||||
(begin-for-syntax
|
||||
(struct target-spec (name-datum name-expression dependencies body source) #:transparent)
|
||||
(define (makefile-prefix-expression stx)
|
||||
(define transformer (syntax-parameter-value #'makefile-prefix))
|
||||
(transformer stx))
|
||||
|
||||
(define (literal-name-datum stx who)
|
||||
(define (makefile-prefix-datum stx)
|
||||
(define expression (makefile-prefix-expression stx))
|
||||
(syntax-parse expression
|
||||
[((~datum quote) value)
|
||||
(syntax-e #'value)]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'makefile
|
||||
"makefile prefix must be a quoted symbol or string"
|
||||
stx)]))
|
||||
|
||||
(define (static-name-datum stx)
|
||||
(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))
|
||||
(raise-syntax-error
|
||||
'target
|
||||
"quoted target name must be a symbol, string, or path"
|
||||
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))
|
||||
[_ #f]))
|
||||
|
||||
(define (procedure-identifier context prefix target)
|
||||
(define name
|
||||
@@ -134,96 +128,134 @@
|
||||
(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 (dynamic-target-expression prefix-expression name dependencies body)
|
||||
#`(let* ([target-name #,name]
|
||||
[target-procedure
|
||||
(procedure-rename
|
||||
(λ ()
|
||||
(call-target-procedure
|
||||
#,prefix-expression
|
||||
target-name
|
||||
(λ ()
|
||||
#,@body
|
||||
(void))))
|
||||
(string->symbol
|
||||
(format "makefile-target-~a-~a"
|
||||
#,prefix-expression
|
||||
target-name)))])
|
||||
(register-target!
|
||||
#,prefix-expression
|
||||
target-name
|
||||
(list #,@dependencies)
|
||||
target-procedure)
|
||||
(void))))
|
||||
|
||||
(define-syntax (target stx)
|
||||
(syntax-parse stx
|
||||
#:datum-literals (deps)
|
||||
[(_ name (deps dependency ...) body ...)
|
||||
(define prefix-expression (makefile-prefix-expression stx))
|
||||
(define prefix-datum (makefile-prefix-datum stx))
|
||||
(define static-name (static-name-datum #'name))
|
||||
(define dependencies (syntax->list #'(dependency ...)))
|
||||
(define body-list (syntax->list #'(body ...)))
|
||||
|
||||
(if (and static-name
|
||||
(not (eq? (syntax-local-context) 'expression)))
|
||||
(let ([proc-id
|
||||
(procedure-identifier stx prefix-datum static-name)])
|
||||
#`(begin
|
||||
(define (#,proc-id)
|
||||
(call-target-procedure
|
||||
#,prefix-expression
|
||||
name
|
||||
(λ ()
|
||||
body ...
|
||||
(void))))
|
||||
(register-target!
|
||||
#,prefix-expression
|
||||
name
|
||||
(list dependency ...)
|
||||
#,proc-id)))
|
||||
(dynamic-target-expression
|
||||
prefix-expression
|
||||
#'name
|
||||
dependencies
|
||||
body-list))]
|
||||
|
||||
[(_ name body ...)
|
||||
(define prefix-expression (makefile-prefix-expression stx))
|
||||
(define prefix-datum (makefile-prefix-datum stx))
|
||||
(define static-name (static-name-datum #'name))
|
||||
(define body-list (syntax->list #'(body ...)))
|
||||
|
||||
(if (and static-name
|
||||
(not (eq? (syntax-local-context) 'expression)))
|
||||
(let ([proc-id
|
||||
(procedure-identifier stx prefix-datum static-name)])
|
||||
#`(begin
|
||||
(define (#,proc-id)
|
||||
(call-target-procedure
|
||||
#,prefix-expression
|
||||
name
|
||||
(λ ()
|
||||
body ...
|
||||
(void))))
|
||||
(register-target!
|
||||
#,prefix-expression
|
||||
name
|
||||
'()
|
||||
#,proc-id)))
|
||||
(dynamic-target-expression
|
||||
prefix-expression
|
||||
#'name
|
||||
'()
|
||||
body-list))]))
|
||||
|
||||
(define-syntax (deps stx)
|
||||
(raise-syntax-error 'deps "only valid as the dependency clause of target" stx))
|
||||
|
||||
(define-syntax (phony stx)
|
||||
(syntax-parse stx
|
||||
[(_ name ...)
|
||||
(define prefix-expression (makefile-prefix-expression stx))
|
||||
#`(mark-phony! #,prefix-expression name ...)]))
|
||||
|
||||
(define-syntax (default-target stx)
|
||||
(syntax-parse stx
|
||||
[(_ name)
|
||||
(define prefix-expression (makefile-prefix-expression stx))
|
||||
#`(set-default-target! #,prefix-expression name)]))
|
||||
|
||||
(define-syntax (makefile stx)
|
||||
(syntax-parse stx
|
||||
#:datum-literals (target phony default-target)
|
||||
[(_ prefix clause ...)
|
||||
(define prefix-datum (literal-name-datum #'prefix 'makefile))
|
||||
[(_ ((~datum quote) prefix) form ...)
|
||||
(define prefix-datum (syntax-e #'prefix))
|
||||
(unless (or (symbol? prefix-datum) (string? prefix-datum))
|
||||
(raise-syntax-error
|
||||
'makefile
|
||||
"prefix must be a quoted symbol or string"
|
||||
#'prefix))
|
||||
|
||||
(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))]))
|
||||
(with-syntax ([prefix-expression prefix-expression])
|
||||
#`(begin
|
||||
#,remember-source
|
||||
(begin-makefile! prefix-expression)
|
||||
(splicing-syntax-parameterize
|
||||
([makefile-prefix (λ (stx) #'prefix-expression)])
|
||||
form ...)
|
||||
(current-makefile-prefix prefix-expression)
|
||||
(void)))]
|
||||
|
||||
[(_ prefix form ...)
|
||||
(raise-syntax-error
|
||||
'makefile
|
||||
"prefix must be explicit, for example (makefile 'stuff ...)"
|
||||
#'prefix)]))
|
||||
|
||||
Reference in New Issue
Block a user