75 lines
2.4 KiB
Scheme
75 lines
2.4 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/decode
|
|
scribble/manual)
|
|
|
|
(define-syntax (fw-doc-form stx)
|
|
(syntax-case stx (-> ->*)
|
|
[(_ id (-> a ... b) (arg ...) (docs ...))
|
|
#'(defproc (id (arg a) ...)
|
|
b
|
|
docs ...)]
|
|
[(_ id (->* (mandatory-ctc ...) (optional-ctc ...) range)
|
|
((mandatory-arg ...) ((optional-arg default) ...))
|
|
(docs ...))
|
|
#'(defproc (id (mandatory-arg mandatory-ctc) ...
|
|
(optional-arg optional-ctc default) ...)
|
|
range
|
|
docs ...)]
|
|
|
|
[(_ id ctc () (docs ...))
|
|
#'(defthing id ctc docs ...)]
|
|
|
|
[(_ id whatever ...)
|
|
(begin
|
|
(fprintf (current-error-port) "Cannot parse docs for ~a\n" (syntax->datum #'id))
|
|
#'(defthing id any/c))]))
|
|
|
|
(define-syntax (mapdesc stx)
|
|
(syntax-case stx ()
|
|
[(_ cmd events)
|
|
#'(make-splice (list (index (symbol->string 'cmd))
|
|
(symbol->string 'cmd)
|
|
" ("
|
|
(symbol->string 'events)
|
|
" events)"))]))
|
|
|
|
(define-syntax (export/docs stx)
|
|
(syntax-case stx ()
|
|
[(_ tag docs ...)
|
|
(let ([reg (regexp (format "^~a:" (syntax->datum #'tag)))])
|
|
(with-syntax ([((id ctc argspec docs ...) ...)
|
|
(filter (λ (x)
|
|
(syntax-case x ()
|
|
[(id ctc argspec docs ...)
|
|
(regexp-match reg (format "~a" (syntax->datum #'id)))]))
|
|
(syntax->list #'(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 ()
|
|
[(id tag arg)
|
|
#`(export/docs
|
|
tag
|
|
#,@(let loop ([f-stx (syntax->datum #'arg)])
|
|
(cond
|
|
[(faux-stx? f-stx)
|
|
(datum->syntax #'id
|
|
(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)
|
|
(syntax-case stx ()
|
|
[(_ tag)
|
|
#'(framework-exports/srcloc-preserved conv/export/docs tag)]))
|