suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

defsignature and associated web-server doc changes

Browse Source 
svn: r7927

original commit: ebf4c453ea6383da59a5b9992d159f1b3dcc51f5
This commit is contained in:
Matthew Flatt 2007-12-08 16:16:46 +00:00
parent 2c117e2cc8
commit c294dec680
2 changed files with 167 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/scribble/decode.ss
View File

@ -175,7 +175,7 @@
[(part-collect-decl? (car l)) [(part-collect-decl? (car l))
(loop (cdr l) next? keys (cons (part-collect-decl-element (car l)) colls) accum title tag-prefix tags style)] (loop (cdr l) next? keys (cons (part-collect-decl-element (car l)) colls) accum title tag-prefix tags style)]
[(part-tag-decl? (car l)) [(part-tag-decl? (car l))
(loop (cdr l) next? keys colls accum title tag-prefix (cons (part-tag-decl-tag (car l)) tags) style)] (loop (cdr l) next? keys colls accum title tag-prefix (append tags (list (part-tag-decl-tag (car l)))) style)]
[(and (pair? (cdr l)) [(and (pair? (cdr l))
(splice? (cadr l))) (splice? (cadr l)))
(loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? keys colls accum title tag-prefix tags style)] (loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? keys colls accum title tag-prefix tags style)]

175
collects/scribble/manual.ss
View File

@ -303,6 +303,63 @@
;; ---------------------------------------- ;; ----------------------------------------
(define-struct sig (tagstr))
(define (definition-site name stx-id form?)
(let ([sig (current-signature)])
(if sig
(make-link-element (if form?
"schemesyntaxlink"
"schemevaluelink")
(list (schemefont (symbol->string name)))
`(,(if form? 'sig-form 'sig-val)
,(format "~a::~a" (sig-tagstr sig) name)))
(annote-exporting-library
(to-element (make-just-context name stx-id))))))
(define (id-to-tag id)
(add-signature-tag id #f))
(define (id-to-form-tag id)
(add-signature-tag id #t))
(define (add-signature-tag id form?)
(let ([sig (current-signature)])
(if sig
`(,(if form? 'sig-form 'sig-val)
,(format "~a::~a" (sig-tagstr sig) (syntax-e id)))
(if form?
(register-scheme-form-definition id)
(register-scheme-definition id #t)))))
(define current-signature (make-parameter #f))
(define-syntax-rule (sigelem sig elem)
(*sig-elem (quote-syntax sig) 'elem))
(define (*sig-elem sig elem)
(let ([s (to-element elem)]
[tag (format "~a::~a"
(register-scheme-form-definition sig #t)
elem)])
(make-delayed-element
(lambda (renderer sec ri)
(let* ([vtag `(sig-val ,tag)]
[stag `(sig-form ,tag)]
[sd (resolve-get/tentative sec ri stag)])
(list
(cond
[sd
(make-link-element "schemesyntaxlink" (list s) stag)]
[else
(make-link-element "schemevaluelink" (list s) vtag)]))))
(lambda () s)
(lambda () s))))
(provide sigelem)
;; ----------------------------------------
(provide method xmethod (rename-out [method ::])) (provide method xmethod (rename-out [method ::]))
(define-syntax method (define-syntax method
@ -316,7 +373,7 @@
(elem (method a b) " in " (scheme a))])) (elem (method a b) " in " (scheme a))]))
(define (*method sym id) (define (*method sym id)
(**method sym (register-scheme-definition id #t))) (**method sym (id-to-tag id)))
(define (**method sym tag) (define (**method sym tag)
(make-element (make-element
@ -596,7 +653,7 @@
(define-syntax defthing (define-syntax defthing
(syntax-rules () (syntax-rules ()
[(_ id result desc ...) [(_ id result desc ...)
(*defthing (quote-syntax/loc id) 'id (quote-syntax result) (lambda () (list desc ...)))])) (*defthing (quote-syntax/loc id) 'id #f (schemeblock0 result) (lambda () (list desc ...)))]))
(define-syntax defparam (define-syntax defparam
(syntax-rules () (syntax-rules ()
[(_ id arg contract desc ...) [(_ id arg contract desc ...)
@ -782,7 +839,7 @@
(hspace 1) (hspace 1)
(if first? (if first?
(let* ([mname (car prototype)] (let* ([mname (car prototype)]
[ctag (register-scheme-definition within-id #t)] [ctag (id-to-tag within-id)]
[tag (method-tag ctag mname)] [tag (method-tag ctag mname)]
[content (list (*method mname within-id))]) [content (list (*method mname within-id))])
(if tag (if tag
@ -799,18 +856,14 @@
(syntax-e within-id) (syntax-e within-id)
libs libs
mname mname
(register-scheme-definition ctag)))))
within-id #t))))))
tag) tag)
(car content))) (car content)))
(*method (car prototype) within-id))))] (*method (car prototype) within-id))))]
[else [else
(if first? (if first?
(let ([tag (register-scheme-definition stx-id #t)] (let ([tag (id-to-tag stx-id)]
[content (list [content (list (definition-site (car prototype) stx-id #f))])
(annote-exporting-library
(to-element (make-just-context (car prototype)
stx-id))))])
(if tag (if tag
(make-toc-target-element (make-toc-target-element
#f #f
@ -1015,11 +1068,10 @@
(apply string-append (apply string-append
(map symbol->string (cdar wrappers)))] (map symbol->string (cdar wrappers)))]
[tag [tag
(register-scheme-definition (id-to-tag
(datum->syntax stx-id (datum->syntax stx-id
(string->symbol (string->symbol
name)) name)))])
#t)])
(if tag (if tag
(inner-make-target-element (inner-make-target-element
#f #f
@ -1212,19 +1264,23 @@
fields field-contracts))) fields field-contracts)))
(content-thunk)))) (content-thunk))))
(define (*defthing stx-id name result-contract content-thunk) (define (*defthing stx-id name form? result-contract content-thunk)
(define spacer (hspace 1)) (define spacer (hspace 1))
(make-splice (make-splice
(cons (cons
(make-table (make-table
'boxed 'boxed
(list
(list
(make-flow
(make-table-if-necessary
"argcontract"
(list (list
(list (make-flow (list (make-flow
(list (list
(make-paragraph (make-paragraph
(list (let ([tag (register-scheme-definition stx-id #t)] (list (let ([tag ((if form? id-to-form-tag id-to-tag) stx-id)]
[content (list (annote-exporting-library [content (list (definition-site name stx-id form?))])
(to-element (make-just-context name stx-id))))])
(if tag (if tag
(make-toc-target-element (make-toc-target-element
#f #f
@ -1238,8 +1294,12 @@
(make-thing-index-desc name libs))))) (make-thing-index-desc name libs)))))
tag) tag)
(car content))) (car content)))
spacer ":" spacer spacer ":" spacer))))
(to-element result-contract)))))))) (make-flow
(list
(if (flow-element? result-contract)
result-contract
(make-paragraph (list result-contract))))))))))))
(content-thunk)))) (content-thunk))))
(define (meta-symbol? s) (memq s '(... ...+ ?))) (define (meta-symbol? s) (memq s '(... ...+ ?)))
@ -1282,13 +1342,13 @@
`(,x . ,(cdr form))))))) `(,x . ,(cdr form)))))))
(and kw-id (and kw-id
(eq? form (car forms)) (eq? form (car forms))
(let ([tag (register-scheme-definition kw-id #t)] (let ([tag (id-to-tag kw-id)]
[stag (register-scheme-form-definition kw-id)] [stag (id-to-form-tag kw-id)]
[content (list (annote-exporting-library [content (list (definition-site (if (pair? form)
(to-element (make-just-context (if (pair? form)
(car form) (car form)
form) form)
kw-id))))]) kw-id
#t))])
(if tag (if tag
(make-target-element (make-target-element
#f #f
@ -1660,7 +1720,7 @@
(list (make-flow (list (make-flow
(list (list
(make-paragraph (make-paragraph
(list (let ([tag (register-scheme-definition stx-id)] (list (let ([tag (id-to-tag stx-id)]
[content (list (annote-exporting-library (to-element stx-id)))]) [content (list (annote-exporting-library (to-element stx-id)))])
(if tag (if tag
((if whole-page? ((if whole-page?
@ -1871,10 +1931,11 @@
(if v (if v
(cons (cls/intf-super v) (cons (cls/intf-super v)
(cls/intf-intfs v)) (cls/intf-intfs v))
null)))]) null)))]
[ctag (id-to-tag cname)])
(make-delayed-element (make-delayed-element
(lambda (r d ri) (lambda (r d ri)
(let loop ([search (get d ri (register-scheme-definition cname))]) (let loop ([search (get d ri ctag)])
(cond (cond
[(null? search) [(null? search)
(make-element #f "<method not found>")] (make-element #f "<method not found>")]
@ -1903,4 +1964,64 @@
null)))) null))))
;; ---------------------------------------- ;; ----------------------------------------
(provide defsignature
defsignature/splice
signature-desc)
(define-syntax defsignature
(syntax-rules ()
[(_ name (super ...) body ...)
(*defsignature
(quote-syntax name)
(list (quote-syntax super) ...)
(lambda ()
(list body ...))
#t)]))
(define-syntax defsignature/splice
(syntax-rules ()
[(_ name (super ...) body ...)
(*defsignature
(quote-syntax name)
(list (quote-syntax super) ...)
(lambda ()
(list body ...))
#f)]))
(define-struct sig-desc (in))
(define (signature-desc . l)
(make-sig-desc l))
(define (*defsignature stx-id supers body-thunk indent?)
(*defthing stx-id (syntax-e stx-id) #t (make-element #f '("signature"))
(lambda ()
(let ([in (parameterize ([current-signature (make-sig
(id-to-form-tag stx-id))])
(body-thunk))])
(if indent?
(let-values ([(pre-body post-body)
(let loop ([in in][pre-accum null])
(cond
[(null? in) (values (reverse pre-accum) null)]
[(whitespace? (car in))
(loop (cdr in) (cons (car in)
pre-accum))]
[(sig-desc? (car in))
(loop (cdr in) (append (reverse (sig-desc-in (car in)))
pre-accum))]
[else
(values (reverse pre-accum) in)]))])
(append
pre-body
(list
(make-blockquote
"leftindent"
(flow-paragraphs
(decode-flow
post-body))))))
in)))))
;; ----------------------------------------
) )