89 lines
3.4 KiB
Scheme
89 lines
3.4 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scribble/manual
|
|
scribble/decode
|
|
scribble/srcdoc
|
|
(for-syntax scheme/base
|
|
syntax/path-spec))
|
|
|
|
(provide include-extracted)
|
|
|
|
(define-for-syntax (strip-context c)
|
|
(cond
|
|
[(syntax? c) (datum->syntax
|
|
#f
|
|
(strip-context (syntax-e c))
|
|
c)]
|
|
[(pair? c) (cons (strip-context (car c))
|
|
(strip-context (cdr c)))]
|
|
[else c]))
|
|
|
|
(define-syntax (include-extracted stx)
|
|
(syntax-case stx ()
|
|
[(_ orig-path)
|
|
(let ([path (resolve-path-spec #'orig-path #'orig-path stx)])
|
|
(let ([s-exp
|
|
(parameterize ([current-namespace (make-base-namespace)]
|
|
[read-accept-reader #t])
|
|
(expand
|
|
(with-input-from-file path
|
|
(lambda ()
|
|
(port-count-lines! (current-input-port))
|
|
(read-syntax path)))))])
|
|
(syntax-case s-exp ()
|
|
[(mod name lang
|
|
(mod-beg
|
|
content ...))
|
|
(with-syntax ([(content ...)
|
|
(apply
|
|
append
|
|
(map (lambda (c)
|
|
(syntax-case c (#%plain-app void quote-syntax provide/doc)
|
|
[(#%plain-app void (quote-syntax (provide/doc spec ...)))
|
|
(syntax->list #'(spec ...))]
|
|
[_ null]))
|
|
(syntax->list #'(content ...))))]
|
|
[(req ...)
|
|
(map
|
|
strip-context
|
|
(apply
|
|
append
|
|
(map (lambda (c)
|
|
(syntax-case c (#%require #%plain-app void quote-syntax require/doc)
|
|
[(#%require spec ...)
|
|
(syntax->list #'((for-label spec) ...))]
|
|
[(#%plain-app void (quote-syntax (require/doc spec ...)))
|
|
(syntax->list #'(spec ...))]
|
|
[_ null]))
|
|
(syntax->list #'(content ...)))))]
|
|
[orig-tag (datum->syntax #f 'orig)])
|
|
#`(begin
|
|
(#%require (for-label #,(strip-context #'lang))
|
|
(for-label #,(strip-context #'orig-path))
|
|
req ...)
|
|
(def-it orig-tag content) ...))])))]))
|
|
|
|
(define-for-syntax (revise-context c orig-tag new-tag tag)
|
|
(cond
|
|
[(syntax? c)
|
|
(datum->syntax
|
|
(if (bound-identifier=? tag (datum->syntax c 'tag))
|
|
new-tag
|
|
orig-tag)
|
|
(revise-context (syntax-e c) orig-tag new-tag tag)
|
|
c)]
|
|
[(pair? c) (cons (revise-context (car c) orig-tag new-tag tag)
|
|
(revise-context (cdr c) orig-tag new-tag tag))]
|
|
[else c]))
|
|
|
|
(define-syntax (def-it stx)
|
|
(syntax-local-introduce
|
|
(syntax-case (syntax-local-introduce stx) ()
|
|
[(_ orig-path (reqs doc tag))
|
|
(let ([new-tag ((make-syntax-introducer)
|
|
(datum->syntax #'orig-path 'new-tag))]
|
|
[orig-tag #'orig-path])
|
|
#`(begin
|
|
(require . #,(revise-context #'reqs orig-tag new-tag #'tag))
|
|
#,(revise-context #'doc orig-tag new-tag #'tag)))])))
|