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

turn on GUI doc generation in scribblings setup

Browse Source 
svn: r7118

original commit: 190b8f6e21d10486c9bac51a5e09937ab92dd7a3
This commit is contained in:
Matthew Flatt 2007-08-18 22:37:36 +00:00
parent f45096ef94
commit e8dc197a92
1 changed files with 112 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

171
collects/scribble/manual.ss
View File

@ -720,7 +720,7 @@
(not result-next-line?)) (not result-next-line?))
end end
not-end)) not-end))
(loop ((if dots-next? cddr cdr) args) (sub1 req)))))))))))))) (loop ((if dots-next? cddr cdr) args) (sub1 req))))))))))))))
(if result-next-line? (if result-next-line?
(list (list (make-flow (make-table-if-necessary (list (list (make-flow (make-table-if-necessary
"prototype" "prototype"
@ -1241,35 +1241,63 @@
(define-syntax-parameter current-class #f) (define-syntax-parameter current-class #f)
(define class-decls (make-hash-table 'equal)) (define-struct decl (name super intfs mk-head body methods))
(define-struct decl (name super intfs mk-body))
(define-struct constructor (def)) (define-struct constructor (def))
(define-struct meth (mode desc def)) (define-struct meth (name mode desc def))
(define-struct spec (def)) (define-struct spec (def))
(define-struct impl (def)) (define-struct impl (def))
(define (register-class name super intfs body) (define-for-syntax (class-id->class-doc-info-id id)
(let ([key (register-scheme-definition name)]) (datum->syntax-object id
(hash-table-put! class-decls (string->symbol (format "class-doc-info:~a" (syntax-e id)))
key id))
(make-decl name super intfs body))))
(define (*include-class name) (define-syntax (define-class-doc-info stx)
(let ([decl (hash-table-get class-decls (register-scheme-definition name))]) (syntax-case stx ()
(make-splice [(_ id val)
(cons (section #:style 'hidden (to-element (decl-name decl))) (with-syntax ([id (class-id->class-doc-info-id #'id)])
(map (lambda (i) #'(begin
(cond (provide id)
[(constructor? i) ((constructor-def i))] (define id val)))]))
[(meth? i)
((meth-def i) (meth-desc i))] (define-syntax (class-doc-info stx)
[else i])) (syntax-case stx (object%)
((decl-mk-body decl) #t)))))) [(_ object%) #'#f]
[(_ id) (class-id->class-doc-info-id #'id)]))
(define (register-class name super intfs mk-head body)
(let ([ht (make-hash-table)])
(when super
(hash-table-for-each (decl-methods super)
(lambda (k v)
(hash-table-put! ht k v))))
(for-each (lambda (intf)
(hash-table-for-each (decl-methods intf)
(lambda (k v)
(hash-table-put! ht k v))))
intfs)
(for-each (lambda (i)
(when (meth? i)
(hash-table-put! ht (meth-name i) (cons name i))))
body)
(make-decl name super intfs mk-head body ht)))
(define (*include-class decl)
(make-splice
(cons (section #:style 'hidden (to-element (decl-name decl)))
(map (lambda (i)
(cond
[(constructor? i) ((constructor-def i))]
[(meth? i)
((meth-def i) (meth-desc i))]
[else i]))
(append
((decl-mk-head decl) #t)
(decl-body decl))))))
(define-syntax include-class (define-syntax include-class
(syntax-rules () (syntax-rules ()
[(_ id) (*include-class (quote-syntax id))])) [(_ id) (*include-class (class-doc-info id))]))
(define (*defclass stx-id super intfs whole-page?) (define (*defclass stx-id super intfs whole-page?)
(let ([spacer (hspace 1)]) (let ([spacer (hspace 1)])
@ -1324,34 +1352,34 @@
(define-syntax defclass (define-syntax defclass
(syntax-rules () (syntax-rules ()
[(_ name super (intf ...) body ...) [(_ name super (intf ...) body ...)
(syntax-parameterize ([current-class (quote-syntax name)]) (define-class-doc-info name
(register-class (quote-syntax name) (syntax-parameterize ([current-class (quote-syntax name)])
(quote-syntax super) (register-class (quote-syntax name)
(list (quote-syntax intf) ...) (class-doc-info super)
(lambda (whole-page?) (list (class-doc-info intf) ...)
(append (lambda (whole-page?)
(list (list
(*defclass (quote-syntax name) (*defclass (quote-syntax name)
(quote-syntax super) (quote-syntax super)
(list (quote-syntax intf) ...) (list (quote-syntax intf) ...)
whole-page?)) whole-page?)))
(list body ...)))))])) (list body ...))))]))
(define-syntax definterface (define-syntax definterface
(syntax-rules () (syntax-rules ()
[(_ name (intf ...) body ...) [(_ name (intf ...) body ...)
(syntax-parameterize ([current-class (quote-syntax name)]) (define-class-doc-info name
(register-class (quote-syntax name) (syntax-parameterize ([current-class (quote-syntax name)])
#f (register-class (quote-syntax name)
(list (quote-syntax intf) ...) #f
(lambda (whole-page?) (list (class-doc-info intf) ...)
(append (lambda (whole-page?)
(list (list
(*defclass (quote-syntax name) (*defclass (quote-syntax name)
#f #f
(list (quote-syntax intf) ...) (list (quote-syntax intf) ...)
whole-page?)) whole-page?)))
(list body ...)))))])) (list body ...))))]))
(define-syntax (defconstructor*/* stx) (define-syntax (defconstructor*/* stx)
(syntax-case stx () (syntax-case stx ()
@ -1404,19 +1432,32 @@
(define-syntax (defmethod* stx) (define-syntax (defmethod* stx)
(syntax-case stx () (syntax-case stx ()
[(_ #:mode mode ([(name arg ...) result-type] ...) desc ...) [(_ #:mode mode ([(name arg ...) result-type] ...) desc ...)
(with-syntax ([cname (syntax-parameter-value #'current-class)]) (with-syntax ([cname (syntax-parameter-value #'current-class)]
#'(make-meth 'mode [name1 (car (syntax->list #'(name ...)))])
(lambda () (make-splice (apply (with-syntax ([(extra ...) (case (syntax-e #'mode)
append [(pubment)
(map (lambda (f) #'((t "Refine this method with " (scheme augment) "."))]
(cond [(override extend augment)
[(impl? f) ((impl-def f))] #'((t (case (syntax-e #'mode)
[(spec? f) ((spec-def f))] [(override) "Overrides "]
[else (list f)])) [(extend) "Extends "]
(list desc ...))))) [(augment) "Augments "])
(lambda (desc-splice) (*xmethod/super (class-doc-info cname) 'name1) "."))]
(defproc* #:mode send #:within cname ([(name arg ...) result-type] ...) [else
(desc-splice)))))] null])])
#'(make-meth 'name1
'mode
(lambda () (make-splice (apply
append
(map (lambda (f)
(cond
[(impl? f) ((impl-def f))]
[(spec? f) ((spec-def f))]
[else (list f)]))
(list extra ... desc ...)))))
(lambda (desc-splice)
(defproc* #:mode send #:within cname ([(name arg ...) result-type] ...)
(desc-splice))))))]
[(_ ([(name arg ...) result-type] ...) desc ...) [(_ ([(name arg ...) result-type] ...) desc ...)
#'(defmethod* #:mode public ([(name arg ...) result-type] ...) desc ...)])) #'(defmethod* #:mode public ([(name arg ...) result-type] ...) desc ...)]))
@ -1444,5 +1485,17 @@
(with-syntax ([cname (syntax-parameter-value #'current-class)]) (with-syntax ([cname (syntax-parameter-value #'current-class)])
#'(*this-obj 'cname))])) #'(*this-obj 'cname))]))
(define (*xmethod/super decl name)
(let ([super (ormap (lambda (decl)
(and decl
(let ([m (hash-table-get (decl-methods decl) name #f)])
(and m (car m)))))
(cons (decl-super decl)
(decl-intfs decl)))])
(make-element #f
(list (*method name super)
" in "
(to-element super)))))
;; ---------------------------------------- ;; ----------------------------------------
) )