suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 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

105
collects/scribble/manual.ss
View File

@ -1241,22 +1241,48 @@
(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 ()
[(_ id val)
(with-syntax ([id (class-id->class-doc-info-id #'id)])
#'(begin
(provide id)
(define id val)))]))
(define-syntax (class-doc-info stx)
(syntax-case stx (object%)
[(_ 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 (make-splice
(cons (section #:style 'hidden (to-element (decl-name decl))) (cons (section #:style 'hidden (to-element (decl-name decl)))
(map (lambda (i) (map (lambda (i)
@ -1265,11 +1291,13 @@
[(meth? i) [(meth? i)
((meth-def i) (meth-desc i))] ((meth-def i) (meth-desc i))]
[else i])) [else i]))
((decl-mk-body decl) #t)))))) (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 ...)
(define-class-doc-info name
(syntax-parameterize ([current-class (quote-syntax name)]) (syntax-parameterize ([current-class (quote-syntax name)])
(register-class (quote-syntax name) (register-class (quote-syntax name)
(quote-syntax super) (class-doc-info super)
(list (quote-syntax intf) ...) (list (class-doc-info intf) ...)
(lambda (whole-page?) (lambda (whole-page?)
(append
(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 ...)
(define-class-doc-info name
(syntax-parameterize ([current-class (quote-syntax name)]) (syntax-parameterize ([current-class (quote-syntax name)])
(register-class (quote-syntax name) (register-class (quote-syntax name)
#f #f
(list (quote-syntax intf) ...) (list (class-doc-info intf) ...)
(lambda (whole-page?) (lambda (whole-page?)
(append
(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,8 +1432,21 @@
(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 ...)))])
(with-syntax ([(extra ...) (case (syntax-e #'mode)
[(pubment)
#'((t "Refine this method with " (scheme augment) "."))]
[(override extend augment)
#'((t (case (syntax-e #'mode)
[(override) "Overrides "]
[(extend) "Extends "]
[(augment) "Augments "])
(*xmethod/super (class-doc-info cname) 'name1) "."))]
[else
null])])
#'(make-meth 'name1
'mode
(lambda () (make-splice (apply (lambda () (make-splice (apply
append append
(map (lambda (f) (map (lambda (f)
@ -1413,10 +1454,10 @@
[(impl? f) ((impl-def f))] [(impl? f) ((impl-def f))]
[(spec? f) ((spec-def f))] [(spec? f) ((spec-def f))]
[else (list f)])) [else (list f)]))
(list desc ...))))) (list extra ... desc ...)))))
(lambda (desc-splice) (lambda (desc-splice)
(defproc* #:mode send #:within cname ([(name arg ...) result-type] ...) (defproc* #:mode send #:within cname ([(name arg ...) result-type] ...)
(desc-splice)))))] (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)))))
;; ---------------------------------------- ;; ----------------------------------------
) )