bkyk8rc3zvpnsf5inmcqq4n3k98cv6hj-my-site-hyper-literate-git.test.suzanne.soy-0.0.1

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

extract.rkt (2036B)

      1 #lang racket/base
      2 (require (for-syntax racket/base))
      3 
      4 (provide include-extracted
      5          provide-extracted
      6          include-previously-extracted)
      7 
      8 (define-for-syntax (do-include-extracted stx wraps)
      9   (syntax-case stx ()
     10     [(_ module-path)
     11      (with-syntax ([get-docs (syntax-local-lift-require 
     12                               #`(only (submod #,@(syntax-case #'module-path (submod)
     13                                                    [(submod e ...) #'(e ...)]
     14                                                    [e #'(e)])
     15                                               srcdoc)
     16                                       get-docs)
     17                               #'get-docs)]
     18                    [(wrap ...) wraps])
     19        #'(begin
     20            (define-syntax (docs stx)
     21              (define docs (get-docs))
     22              (if (identifier? docs)
     23                  ;; normal:
     24                  (with-syntax ([(_ xwrap (... ...)) stx]
     25                                [id docs])
     26                    #'(xwrap (... ...) id))
     27                  ;; delayed:
     28                  (with-syntax ([(_ xwrap (... ...)) stx]
     29                                [(reqs exprs ((id d) (... ...))) (syntax-local-introduce
     30                                                                  (datum->syntax #f (get-docs)))])
     31                    #`(begin
     32                        (require . reqs)
     33                        (begin . exprs)
     34                        (xwrap (... ...) (list (cons 'id d) (... ...)))))))
     35            (docs wrap ...)))]))
     36 
     37 (define-syntax (include-extracted stx)
     38   (do-include-extracted stx #'(map cdr)))
     39   
     40 (define-syntax (provide-extracted stx)
     41   (syntax-case stx ()
     42     [(_ module-path)
     43      #`(begin
     44          #,(do-include-extracted stx #'(define exported))
     45          (provide exported))]))
     46   
     47 (define-syntax-rule (include-previously-extracted module-path regexp)
     48   (let ()
     49     (local-require (rename-in module-path [exported exported]))
     50     (for/list ([p (in-list exported)]
     51                #:when (regexp-match regexp (symbol->string (car p))))
     52       (cdr p))))
     53