45 lines
1.2 KiB
Scheme
45 lines
1.2 KiB
Scheme
#lang scheme/base
|
|
|
|
(provide def-fw-procs)
|
|
|
|
(require (for-label scheme/contract)
|
|
(for-label framework/framework))
|
|
|
|
(require "private/framework-exports.ss"
|
|
(for-syntax scheme/base)
|
|
scribble/manual)
|
|
|
|
(define-syntax (fw-doc-form stx)
|
|
(syntax-case stx (->)
|
|
[(_ id (-> a ... b) (arg ...) docs ...)
|
|
#'(defproc (id (arg a) ...)
|
|
b)]
|
|
|
|
[(_ id b () docs ...)
|
|
#'(defthing id b)]
|
|
|
|
[(_ id whatever ...)
|
|
#'(defthing id any/c)]))
|
|
|
|
(define-syntax (export/docs stx)
|
|
(syntax-case stx ()
|
|
[(_ (id ctc argspec docs ...) ...)
|
|
#'(begin (fw-doc-form id ctc argspec docs ...) ...)]))
|
|
|
|
(define-syntax (conv/export/docs stx)
|
|
(define-struct faux-stx (obj vec) #:prefab)
|
|
(syntax-case stx ()
|
|
[(_ arg)
|
|
#`(export/docs
|
|
#,@(let loop ([f-stx (syntax->datum #'arg)])
|
|
(cond
|
|
[(faux-stx? f-stx)
|
|
(datum->syntax stx
|
|
(loop (faux-stx-obj f-stx))
|
|
(faux-stx-vec f-stx))]
|
|
[(pair? f-stx) (cons (loop (car f-stx)) (loop (cdr f-stx)))]
|
|
[else f-stx])))]))
|
|
|
|
(define-syntax (def-fw-procs stx)
|
|
#'(framework-exports/srcloc-preserved conv/export/docs))
|