suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add lazy-require-syntax

Browse Source
This commit is contained in:
Ryan Culpepper 2017-12-14 12:04:18 +01:00
parent fb80d18428
commit 8d04bd67d6
1 changed files with 111 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

140
racket/collects/racket/lazy-require.rkt
View File

@ -3,16 +3,22 @@
compiler/cm-accomplice
racket/runtime-path
racket/promise)
(provide lazy-require)
(provide lazy-require
lazy-require-syntax)
(define-syntax (lazy-require stx)
(syntax-case stx ()
[(lazy-require [modpath (thing ...)] ...)
#`(begin (lazy-require1 modpath (thing ...) #,stx) ...)]))
(define-for-syntax counter 0)
[(lazy-require [modpath (import ...)] ...)
#`(begin (lazy-require1 modpath (import ...) #,stx) ...)]))
(begin-for-syntax
(define counter 0)
(define (gen-aux-mod-name phase)
(begin0 (string->symbol (format "lazy-require-aux-~a-~a" phase counter))
(set! counter (add1 counter))))
;; like (collapse-module-path modpath '(submod "..")), but avoids
;; the dependencies of syntax/modcollapse
(define (module-path-add-submod-up modpath)
@ -33,40 +39,38 @@
modpath]))]
[else
;; wasn't a submod module-path
modpath]))))
modpath])))
(define (process-imports ctx imports)
(for/list ([import (in-list imports)])
(syntax-case import ()
[name
(identifier? #'name)
(list #'name #'name)]
[[exp-name bind-name]
(begin
(unless (identifier? #'exp-name)
(raise-syntax-error #f "expected identifier" #'orig-stx #'exp-name))
(unless (identifier? #'bind-name)
(raise-syntax-error #f "expected identifier" #'orig-stx #'bind-name))
(list #'exp-name #'bind-name))]
[bad
(raise-syntax-error #f "expected identifier or pair of identifiers"
#'orig-stx #'bad)])))
)
(define-syntax (lazy-require1 stx)
(syntax-case stx ()
[(lazy-require1 modpath (thing ...) orig-stx)
[(lazy-require1 modpath (import ...) orig-stx)
(with-syntax ([((exp-name bind-name) ...)
(for/list ([thing-stx (in-list (syntax->list #'(thing ...)))])
(syntax-case thing-stx ()
[name
(identifier? #'name)
(list #'name #'name)]
[[exp-name bind-name]
(begin
(unless (identifier? #'exp-name)
(raise-syntax-error #f "expected identifier"
#'orig-stx #'exp-name))
(unless (identifier? #'bind-name)
(raise-syntax-error #f "expected identifier"
#'orig-stx #'bind-name))
(list #'exp-name #'bind-name))]
[_
(raise-syntax-error #f "expected identifier or pair of identifiers"
#'orig-stx thing-stx)]))]
(process-imports #'orig-stx (syntax->list #'(import ...)))]
[mpi-var-defn
(let ([phase (sub1 (variable-reference->phase (#%variable-reference)))])
(if (zero? phase)
;; `define-runtime-module-path-index' works right at phase-level 0:
#'(define-runtime-module-path-index mpi-var (quote modpath))
;; need a submodule:
(with-syntax ([lazy-require-path-n
(string->symbol
(format "lazy-require-path-~a-~a"
phase
counter))]
(with-syntax ([lazy-require-path-n (gen-aux-mod-name phase)]
;; May need to adjust modpath, since we're interpreting it
;; relative to a *submodule* of the original context.
;; ie, module-path interpretation is not hygienic!
@ -111,3 +115,81 @@
(variable-reference->resolved-module-path vr))))])
(when (path? path)
(register-external-module path #:indirect? #t))))
;; ----
(define-syntax (lazy-require-syntax stx)
(syntax-case stx ()
[(_ [modpath (import ...)] ...)
#`(begin (lazy-require-syntax1/rename modpath (import ...) #,stx) ...)]))
#|
;; Implementation 1: syntax-local-value to get macro transformer
;; This version only works for "standard" macros. It doesn't work with
;; set!-transformers. It only supports the macro-nature of syntax
;; bindings like struct names (you can use them as constructors, but not
;; as match patterns).
(define-syntax (lazy-require-syntax1/transformer stx)
(syntax-case stx ()
[(_ modpath (import ...) orig-stx)
(with-syntax ([modpath* (module-path-add-submod-up #'modpath)]
[((exp-name bind-name) ...)
(process-imports #'orig-stx (syntax->list #'(import ...)))]
[aux-mod1 (gen-aux-mod-name '*)]
[aux-mod2 (gen-aux-mod-name '*)])
(with-syntax ([(get-tx ...) (generate-temporaries #'(exp-name ...))])
#'(begin
(module aux-mod1 racket/base
(require (only-in (for-template modpath*) exp-name ...))
(define (get-tx) (syntax-local-value (quote-syntax exp-name))) ...
(provide get-tx ...))
(module aux-mod2 racket/base
(require (only-in racket/lazy-require lazy-require))
(lazy-require [(submod ".." aux-mod1) (get-tx ...)])
(provide get-tx ...))
(require (for-syntax (only-in (submod "." aux-mod2) [get-tx get-tx] ...)))
(define-syntax (bind-name stx) ((get-tx) stx)) ...)))]))
|#
;; Implementation 2: lazy rename-transformers
;; This version is more flexible, since rename-transformers support
;; ordinary variables and syntax bindings other than or more than macros
;; (eg struct information).
(begin-for-syntax
(struct lazy-rename-transformer (get-id)
#:property prop:rename-transformer
(lambda (self)
(syntax-property ((lazy-rename-transformer-get-id self))
'not-free-identifier=? #t))))
(define-syntax (lazy-require-syntax1/rename stx)
(syntax-case stx ()
[(_ modpath (import ...) orig-stx)
(with-syntax ([modpath* (module-path-add-submod-up #'modpath)]
[((exp-name bind-name) ...)
(process-imports #'orig-stx (syntax->list #'(import ...)))]
[aux-mod1 (gen-aux-mod-name '*)]
[aux-mod2 (gen-aux-mod-name '*)])
(with-syntax ([(get-id ...) (generate-temporaries #'(exp-name ...))]
[(bind-aux ...) (generate-temporaries #'(bind-name ...))])
#'(begin
(module aux-mod1 racket/base
(#%require (for-template (only modpath* exp-name ...)))
(define (get-id) (quote-syntax exp-name)) ...
(provide get-id ...))
(module aux-mod2 racket/base
(require (only-in racket/lazy-require lazy-require))
(lazy-require [(submod ".." aux-mod1) (get-id ...)])
(provide get-id ...))
(require (for-syntax (only-in (submod "." aux-mod2) [get-id get-id] ...)))
;; Use extra indirection (bind-name -> bind-aux) so that (provide bind-name)
;; doesn't force (get-id) trying to decide whether to bypass renamer.
(define-syntax bind-aux (lazy-rename-transformer get-id)) ...
(define-syntax bind-name
(make-rename-transformer
(syntax-property (quote-syntax bind-aux) 'not-free-identifier=? #t)))
...)))]))