(module require mzscheme
(require (lib "etc.ss"))
(require-for-syntax (lib "stx.ss" "syntax")
(lib "etc.ss")
"require-ct.ss")
(provide define-module
define-library
hygienic:define-module
hygienic:define-library)
(define-for-syntax (make-here-expr stx)
(datum->syntax-object stx `(,#'this-expression-source-directory) stx stx))
(define-syntax (define-module stx)
(syntax-case stx ()
[(_ name mod-spec ...)
(begin
(unless (identifier? #'name)
(raise-syntax-error 'define-module "expected identifier" #'name))
(for-each (lambda (ms)
(unless (or (absolute-mod-spec? ms) (relative-mod-spec? ms))
(raise-syntax-error 'define-module "bad module spec" ms)))
(syntax->list #'(mod-spec ...)))
(with-syntax ([name
(datum->syntax-object #'name
(join 'require- #'name)
#'name)]
[name4stx
(datum->syntax-object #'name
(join 'require-for-syntax- #'name)
#'name)]
[name4templ
(datum->syntax-object #'name
(join 'require-for-template- #'name)
#'name)]
[dynamic-name
(datum->syntax-object #'name
(join 'dynamic-require- #'name)
#'name)]
[namespace-name
(datum->syntax-object #'name
(join 'namespace-require- #'name)
#'name)]
[namespace4stx-name
(datum->syntax-object #'name
(join 'namespace-transformer-require- #'name)
#'name)])
(with-syntax ([(here-expr ...)
(map make-here-expr (syntax->list #'(mod-spec ...)))])
#`(begin
(hygienic:define-module name name4stx name4templ mod-spec ...)
(define (namespace-name)
(parameterize ((current-load-relative-directory here-expr))
(namespace-require 'mod-spec))
...
(void))
(define (namespace4stx-name)
(parameterize ((current-load-relative-directory here-expr))
(namespace-transformer-require 'mod-spec))
...
(void))
#,@(syntax-case #'(mod-spec ...) ()
[(mod-spec1)
(with-syntax ([here-expr1 (make-here-expr #'mod-spec1)])
(list
#'(define (dynamic-name x)
(parameterize ((current-load-relative-directory
here-expr1))
(dynamic-require 'mod-spec1 x)))))]
[_ null])))))]))
(define-syntax (hygienic:define-module stx)
(syntax-case stx ()
[(_ name name4stx name4templ mod-spec ...)
#'(begin
(define-require-form name require mod-spec ...)
(define-require-form name4stx require-for-syntax mod-spec ...)
(define-require-form name4templ require-for-template mod-spec ...))]))
(define-for-syntax (adjust-mod-specs relative-to mod-specs)
(define (adjust mod-spec)
(cond [(pair? mod-spec)
mod-spec]
[else
`(file ,(path->string (build-path relative-to mod-spec)))]))
(map adjust mod-specs))
(define-syntax (define-require-form stx)
(syntax-case stx ()
[(_ name require-form mod-spec ...)
(with-syntax ([here-expr (make-here-expr #'name)])
#`(begin
(define-syntax (name x)
(syntax-case x ()
[(name)
(let ([relative-to here-expr])
(let ([specs (adjust-mod-specs relative-to '(mod-spec ...))])
(datum->syntax-object x `(,#'require-form ,@specs))))]))
#,(if (eq? (syntax-local-context) 'module)
#'(provide name)
#'(begin))))]))
(define-syntax (define-library stx)
(syntax-case stx ()
[(_ name pkg-spec)
(begin
(unless (identifier? #'name)
(raise-syntax-error 'define-library "expected identifier" #'name))
(unless (absolute-mod-spec? #'pkg-spec)
(raise-syntax-error 'define-library "bad absolute module spec" #'pkg-spec))
(with-syntax ([name
(datum->syntax-object #'name
(join 'require- #'name)
#'name)]
[name4stx
(datum->syntax-object #'name
(join 'require-for-syntax- #'name)
#'name)]
[name4templ
(datum->syntax-object #'name
(join 'require-for-template- #'name)
#'name)]
[dynamic-name
(datum->syntax-object #'name
(join 'dynamic-require- #'name)
#'name)]
[namespace-name
(datum->syntax-object #'name
(join 'namespace-require- #'name)
#'name)]
[namespace4stx-name
(datum->syntax-object #'name
(join 'namespace-transformer-require- #'name)
#'name)])
#'(begin
(hygienic:define-library name name4stx name4templ pkg-spec)
(define (namespace-name modname)
(namespace-require (combine-mod-spec 'pkg-spec modname)))
(define (namespace4stx-name modname)
(namespace-transformer-require (combine-mod-spec 'pkg-spec modname)))
(define (dynamic-name modname thing)
(dynamic-require (combine-mod-spec 'pkg-spec modname) thing)))))]))
(define-syntax (hygienic:define-library stx)
(syntax-case stx ()
[(_ name name4stx name4templ abs-mod-spec)
#'(begin
(define-require-abstraction name require abs-mod-spec)
(define-require-abstraction name4stx require-for-syntax abs-mod-spec)
(define-require-abstraction name4templ require-for-template abs-mod-spec))]))
(define-syntax (define-require-abstraction stx)
(syntax-case stx ()
[(_ name require-form abs-mod-spec)
#`(begin
#,(if (eq? (syntax-local-context) 'module)
#'(provide name)
#'(begin))
#,(syntax-case #'abs-mod-spec (lib planet file)
[(lib dir0 subdir ...)
(eq? 'lib (syntax-e #'lib))
#`(define-syntax (name x)
(syntax-case x ()
[(name module-file . morepaths)
(datum->syntax-object
x
`(#,#'require-form
(lib ,#'module-file dir0 subdir ... . ,#'morepaths)))]))]
[(planet pkg subdir ...)
(eq? 'planet (syntax-e #'planet))
#`(define-syntax (name x)
(syntax-case x ()
[(name module-file . morepaths)
(datum->syntax-object
x
`(#,#'require-form
(planet ,#'module-file pkg subdir ... . ,#'morepaths)))]))]
[(file abspath)
(eq? 'file (syntax-e #'file))
#'(define-syntax (name x)
(syntax-case x ()
[(name module-file . morepaths)
(datum->syntax-object
x
`(#,#'require-form
(file ,(path->string
(build-path (apply build-path abspath
(map syntax-e (syntax->list #'morepaths)))
(syntax-e #'module-file))))))]))]))]))
(define (combine-mod-spec abs-mod-spec mod-name)
(case (car abs-mod-spec)
((lib)
`(lib ,mod-name ,@(cdr abs-mod-spec)))
((planet)
`(planet ,mod-name ,@(cdr abs-mod-spec)))
((file)
`(file ,(build-path (cadr abs-mod-spec) mod-name)))))
)