From 4809dfdeb5783ca3f74f00970584706cc0e0a6dd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 19 Mar 2008 19:53:51 +0000 Subject: [PATCH] revise scribble/srcdoc so it is extensible; tweak bytecode optimizer to drop more omittable expressions svn: r9028 original commit: f5e0fd35f53eddf5e51843542103f5ea85d429a2 --- collects/scribble/extract.ss | 52 ++++++++----- collects/scribble/manual.ss | 28 ++++++- collects/scribble/provide-doc-transform.ss | 15 ++++ collects/scribble/srcdoc.ss | 90 ++++++++++++++++++---- 4 files changed, 148 insertions(+), 37 deletions(-) create mode 100644 collects/scribble/provide-doc-transform.ss diff --git a/collects/scribble/extract.ss b/collects/scribble/extract.ss index de0896b5..73d5f79d 100644 --- a/collects/scribble/extract.ss +++ b/collects/scribble/extract.ss @@ -35,16 +35,14 @@ (mod-beg content ...)) (with-syntax ([(content ...) - (map - strip-context - (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 ...)))))] + (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 @@ -57,16 +55,34 @@ [(#%plain-app void (quote-syntax (require/doc spec ...))) (syntax->list #'(spec ...))] [_ null])) - (syntax->list #'(content ...)))))]) + (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 content) ...))])))])) + (def-it orig-tag content) ...))])))])) -(define-syntax def-it - (syntax-rules () - [(_ ((rename old-id id) contract desc)) - (def-it (id contract desc))] - [(_ (id (-> arg ... result) desc)) - (defproc (id arg ...) result . desc)])) +(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)))]))) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index cff03533..9e161721 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -713,7 +713,9 @@ (raise-syntax-error 'defproc "bad prototype" stx)])) (define-syntax (result-contract stx) - (syntax-case stx () + (syntax-case stx (values) + [(_ (values c ...)) + #'(list (schemeblock0 c) ...)] [(_ c) (if (string? (syntax-e #'c)) (raise-syntax-error @@ -1233,7 +1235,29 @@ (element-width tagged))] [(short?) (or (flat-size . < . 40) ((length args) . < . 2))] - [(res) (result-contract)] + [(res) (let ([res (result-contract)]) + (if (list? res) + ;; multiple results + (if (null? res) + 'nbsp + (let ([w (apply max 0 (map flow-element-width res))]) + (if (or (ormap table? res) + (w . > . 30)) + (make-table + #f + (map (lambda (fe) + (list (make-flow (list fe)))) + res)) + (make-table + #f + (list + (let loop ([res res]) + (if (null? (cdr res)) + (list (make-flow (list (car res)))) + (list* (make-flow (list (car res))) + (to-flow (hspace 1)) + (loop (cdr res)))))))))) + res))] [(result-next-line?) ((+ (if short? flat-size (+ (prototype-size args max max) diff --git a/collects/scribble/provide-doc-transform.ss b/collects/scribble/provide-doc-transform.ss new file mode 100644 index 00000000..8c126c1d --- /dev/null +++ b/collects/scribble/provide-doc-transform.ss @@ -0,0 +1,15 @@ +#lang scheme/base + +(require (for-syntax scheme/base)) + +(provide define-provide/doc-transformer + (for-syntax + provide/doc-transformer? + provide/doc-transformer-proc)) + +(begin-for-syntax + (define-struct provide/doc-transformer (proc) #:omit-define-syntaxes)) + +(define-syntax-rule (define-provide/doc-transformer id rhs) + (define-syntax id + (make-provide/doc-transformer rhs))) diff --git a/collects/scribble/srcdoc.ss b/collects/scribble/srcdoc.ss index 1f5e2c2b..01a812d4 100644 --- a/collects/scribble/srcdoc.ss +++ b/collects/scribble/srcdoc.ss @@ -1,27 +1,83 @@ #lang scheme/base -(require scheme/contract) +(require scheme/contract + (for-syntax scheme/base) + "provide-doc-transform.ss") (provide require/doc - provide/doc) + provide/doc + proc-doc) (define-syntax-rule (require/doc spec ...) (void (quote-syntax (require/doc spec ...)))) -(define-syntax-rule (provide/doc [id contract desc] ...) - (begin - (void (quote-syntax (provide/doc [id contract desc] ...))) - (provide/contracted [id (strip-names contract)]) ...)) +(define-syntax (provide/doc stx) + (syntax-case stx () + [(_ form ...) + (let ([forms (syntax->list #'(form ...))]) + (with-syntax ([((for-provide/contract for-docs) ...) + (map (lambda (form) + (syntax-case form () + [(id . _) + (identifier? #'id) + (let ([t (syntax-local-value #'id (lambda () #f))]) + (unless (provide/doc-transformer? t) + (raise-syntax-error + #f + "not bound as a provide/doc transformer" + stx + #'id)) + (let* ([i (make-syntax-introducer)] + [i2 (lambda (x) (syntax-local-introduce (i x)))]) + (let-values ([(p/c d req/d) ((provide/doc-transformer-proc t) + (i (syntax-local-introduce form)))]) + (list (i2 p/c) (list (i2 req/d) (i2 d) (i2 (quote-syntax tag)))))))] + [_ + (raise-syntax-error + #f + "not a provide/doc sub-form" + stx + form)])) + forms)]) + (with-syntax ([(p/c ...) + (map (lambda (form f) + (quasisyntax/loc form + (provide/contract #,f))) + forms + (syntax->list #'(for-provide/contract ...)))]) + #'(begin + p/c ... + (void (quote-syntax (provide/doc for-docs ...)))))))])) -(define-syntax provide/contracted - (syntax-rules (->) - [(_ [(rename orig-id new-id) contract]) - (provide/contract (rename orig-id new-id contract))] - [(_ [id contract]) - (provide/contract [id contract])])) +(define-provide/doc-transformer proc-doc + (lambda (stx) + (syntax-case stx () + [(_ id contract desc) + (with-syntax ([(arg ...) + (syntax-case #'contract (->d) + [(->d (req ...) () result) + #'(req ...)] + [else + (raise-syntax-error + #f + "unsupported procedure contract form (arguments)" + stx + #'contract)])] + [result + (syntax-case #'contract (->d) + [(->d reqs opts (values [name res] ...)) + #'(values res ...)] + [(->d reqs opts [name res]) + #'res] + [else + (raise-syntax-error + #f + "unsupported procedure contract form (arguments)" + stx + #'contract)])]) + (values + #'[id contract] + #'(defproc (id arg ...) result . desc) + #'(scribble/manual)))]))) -(define-syntax strip-names - (syntax-rules (->) - [(_ (-> [id contract] ... result)) - (-> contract ... result)] - [(_ other) other])) +