109 lines
5.0 KiB
Scheme
109 lines
5.0 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) #'(include-extracted orig-path #rx"")] ;; this regexp matches everything
|
|
[(_ orig-path regexp-s)
|
|
(let ([path (resolve-path-spec #'orig-path #'orig-path stx)]
|
|
[reg (syntax-e #'regexp-s)])
|
|
(unless (regexp? reg)
|
|
(raise-syntax-error #f "expected a literal regular expression as the second argument" stx #'regexp-s))
|
|
(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 ...)))
|
|
(map
|
|
(λ (x) (syntax-case x () [(docs id) #'docs]))
|
|
(filter (λ (x)
|
|
(syntax-case x ()
|
|
[(stuff id)
|
|
(regexp-match reg (symbol->string (syntax-e #'id)))]))
|
|
(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 ...)
|
|
(let loop ([specs (syntax->list #'(spec ...))])
|
|
(cond
|
|
[(null? specs) '()]
|
|
[else (let ([spec (car specs)])
|
|
(syntax-case spec (for-syntax for-meta)
|
|
[(for-syntax . spec) (loop (cdr specs))]
|
|
[(for-meta . spec) (loop (cdr specs))]
|
|
[(for-template . spec) (loop (cdr specs))]
|
|
[(for-label . spec) (loop (cdr specs))]
|
|
[(just-meta . spec) (loop (cdr specs))]
|
|
[_ (cons #`(for-label #,spec) (loop (cdr specs)))]))]))]
|
|
[(#%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)))])))
|