537 lines
22 KiB
Racket
537 lines
22 KiB
Racket
#lang scheme/base
|
|
(require "../decode.rkt"
|
|
"../struct.rkt"
|
|
"../scheme.rkt"
|
|
"../search.rkt"
|
|
"../basic.rkt"
|
|
"../manual-struct.rkt"
|
|
"qsloc.rkt"
|
|
scheme/serialize
|
|
scheme/stxparam
|
|
"manual-utils.rkt"
|
|
"manual-style.rkt"
|
|
"manual-scheme.rkt"
|
|
"manual-bind.rkt"
|
|
"manual-method.rkt"
|
|
"manual-proc.rkt"
|
|
"manual-vars.rkt"
|
|
"manual-class-struct.rkt"
|
|
scheme/list
|
|
(for-syntax scheme/base)
|
|
(for-label scheme/base
|
|
scheme/class))
|
|
|
|
(provide defclass
|
|
defclass/title
|
|
definterface
|
|
definterface/title
|
|
defmixin
|
|
defmixin/title
|
|
defconstructor
|
|
defconstructor/make
|
|
defconstructor*/make
|
|
defconstructor/auto-super
|
|
defmethod
|
|
defmethod*
|
|
methspec
|
|
methimpl
|
|
this-obj
|
|
method xmethod (rename-out [method ::]))
|
|
|
|
(define-syntax-parameter current-class #f)
|
|
|
|
(define-struct decl (name super app-mixins intfs ranges mk-head body))
|
|
(define-struct constructor (def))
|
|
(define-struct meth (names mode def))
|
|
(define-struct spec (def))
|
|
(define-struct impl (def))
|
|
|
|
(define (id-info id)
|
|
(let ([b (identifier-label-binding id)])
|
|
(if b
|
|
(list (caddr b)
|
|
(list-ref b 3)
|
|
(list-ref b 4)
|
|
(list-ref b 5)
|
|
(list-ref b 6))
|
|
(error 'scribble "no class/interface/mixin information for identifier: ~e"
|
|
id))))
|
|
|
|
(define (make-inherited-table r d ri decl)
|
|
(define start
|
|
(let ([key (find-scheme-tag d ri (decl-name decl) #f)])
|
|
(if key (list (cons key (lookup-cls/intf d ri key))) null)))
|
|
(define supers
|
|
(if (null? start)
|
|
null
|
|
(cdr
|
|
(let loop ([supers start][accum null])
|
|
(cond
|
|
[(null? supers) (reverse accum)]
|
|
[(assoc (caar supers) accum)
|
|
(loop (cdr supers) accum)]
|
|
[else
|
|
(let ([super (car supers)])
|
|
(loop (append (filter-map
|
|
(lambda (i)
|
|
(let ([key (find-scheme-tag d ri i #f)])
|
|
(and key
|
|
(cons key (lookup-cls/intf d ri key)))))
|
|
(append
|
|
(reverse (cls/intf-intfs (cdr super)))
|
|
(if (cls/intf-super (cdr super))
|
|
(list (cls/intf-super (cdr super)))
|
|
null)
|
|
(reverse (cls/intf-app-mixins (cdr super)))))
|
|
(cdr supers))
|
|
(cons super accum)))])))))
|
|
(define ht
|
|
(let ([ht (make-hasheq)])
|
|
(for* ([i (decl-body decl)]
|
|
#:when (meth? i)
|
|
[name (meth-names i)])
|
|
(hash-set! ht name #t))
|
|
ht))
|
|
(define inh
|
|
(append-map
|
|
(lambda (super)
|
|
(let ([inh (filter-map
|
|
(lambda (k)
|
|
(if (hash-ref ht k #f)
|
|
#f
|
|
(begin (hash-set! ht k #t)
|
|
(cons (datum-intern-literal (symbol->string k))
|
|
(**method k (car super))))))
|
|
(cls/intf-methods (cdr super)))])
|
|
(if (null? inh)
|
|
null
|
|
(cons (make-element #f (list (make-element "inheritedlbl" '("from "))
|
|
(cls/intf-name-element (cdr super))))
|
|
(map cdr (sort inh string<? #:key car))))))
|
|
supers))
|
|
(if (null? inh)
|
|
(make-auxiliary-table "inherited" null)
|
|
(make-auxiliary-table
|
|
"inherited"
|
|
(map (lambda (i) (list (to-flow i)))
|
|
(cons (make-element "inheritedlbl" '("Inherited methods:")) inh)))))
|
|
|
|
(define (make-decl-collect decl link?)
|
|
(if link?
|
|
(make-part-collect-decl
|
|
((id-to-target-maker (decl-name decl) #f)
|
|
(list "ignored")
|
|
(lambda (tag)
|
|
(make-collect-element
|
|
#f null
|
|
(lambda (ci)
|
|
(collect-put!
|
|
ci
|
|
`(cls/intf ,(cadr tag))
|
|
(make-cls/intf
|
|
(make-element
|
|
symbol-color
|
|
(list (make-link-element
|
|
value-link-color
|
|
(list (datum-intern-literal
|
|
(symbol->string (syntax-e (decl-name decl)))))
|
|
tag)))
|
|
(map id-info (decl-app-mixins decl))
|
|
(and (decl-super decl)
|
|
(not (free-label-identifier=? (quote-syntax object%)
|
|
(decl-super decl)))
|
|
(id-info (decl-super decl)))
|
|
(map id-info (decl-intfs decl))
|
|
(append-map (lambda (m)
|
|
(let loop ([l (meth-names m)])
|
|
(cond [(null? l) null]
|
|
[(memq (car l) (cdr l)) (loop (cdr l))]
|
|
[else (cons (car l) (loop (cdr l)))])))
|
|
(filter meth? (decl-body decl))))))))))
|
|
null))
|
|
|
|
(define (build-body decl body)
|
|
`(,@(map (lambda (i)
|
|
(cond [(constructor? i) ((constructor-def i))]
|
|
[(meth? i) ((meth-def i))]
|
|
[else i]))
|
|
body)
|
|
,(make-delayed-block (lambda (r d ri) (make-inherited-table r d ri decl)))))
|
|
|
|
(define (*include-class/title decl link?)
|
|
(make-splice
|
|
(list* (title #:style 'hidden (to-element (decl-name decl)))
|
|
(make-decl-collect decl link?)
|
|
(build-body decl (append ((decl-mk-head decl) #t)
|
|
(decl-body decl))))))
|
|
|
|
(define (*include-class decl link?)
|
|
(make-splice
|
|
(cons
|
|
(make-decl-collect decl link?)
|
|
(append
|
|
((decl-mk-head decl) #f)
|
|
(let-values ([(pre post)
|
|
(let loop ([l (decl-body decl)][accum null])
|
|
(cond
|
|
[(null? l) (values (reverse accum) null)]
|
|
[(or (constructor? (car l)) (meth? (car l)))
|
|
(values (reverse accum) l)]
|
|
[else (loop (cdr l) (cons (car l) accum))]))])
|
|
(append
|
|
(flow-paragraphs (decode-flow pre))
|
|
(list
|
|
(make-blockquote
|
|
"leftindent"
|
|
(flow-paragraphs
|
|
(decode-flow (build-body decl post)))))))))))
|
|
|
|
(define (*class-doc kind stx-id super intfs ranges whole-page? make-index-desc link?)
|
|
(make-table
|
|
boxed-style
|
|
(append
|
|
(list
|
|
(list
|
|
((add-background-label (symbol->string kind))
|
|
(make-flow
|
|
(list
|
|
(make-omitable-paragraph
|
|
(list (if link?
|
|
(let ([target-maker (id-to-target-maker stx-id #t)]
|
|
[content (annote-exporting-library
|
|
(to-element #:defn? #t stx-id))]
|
|
[ref-content (to-element stx-id)])
|
|
(if target-maker
|
|
(target-maker
|
|
content
|
|
(lambda (tag)
|
|
((if whole-page?
|
|
make-page-target-element
|
|
(lambda (s c t)
|
|
(make-toc-target2-element s c t ref-content)))
|
|
#f
|
|
(list
|
|
(make-index-element
|
|
#f content tag
|
|
(list (datum-intern-literal
|
|
(symbol->string (syntax-e stx-id))))
|
|
(list ref-content)
|
|
(with-exporting-libraries
|
|
(lambda (libs)
|
|
(make-index-desc (syntax-e stx-id) libs)))))
|
|
tag)))
|
|
content))
|
|
(to-element stx-id))
|
|
spacer ":" spacer
|
|
(case kind
|
|
[(class) (racket class?)]
|
|
[(interface) (racket interface?)]
|
|
[(mixin) (racketblockelem (class? . -> . class?))]))))))))
|
|
(if super
|
|
(list
|
|
(list (make-flow
|
|
(list (t (hspace 2) "superclass:" spacer (to-element super))))))
|
|
null)
|
|
(let ([show-intfs
|
|
(lambda (intfs range?)
|
|
(if (null? intfs)
|
|
null
|
|
(list
|
|
(list
|
|
(make-flow
|
|
(list
|
|
(make-table
|
|
#f
|
|
(cons
|
|
(list (make-flow
|
|
(list (make-omitable-paragraph
|
|
(list (hspace 2)
|
|
(case kind
|
|
[(interface) "implements:"]
|
|
[(class) "extends:"]
|
|
[(mixin)
|
|
(if range?
|
|
"result implements:"
|
|
"argument extends/implements:")])
|
|
spacer))))
|
|
(to-flow (to-element (car intfs))))
|
|
(map (lambda (i)
|
|
(list flow-spacer (to-flow (to-element i))))
|
|
(cdr intfs))))))))))])
|
|
(append (show-intfs intfs #f) (show-intfs ranges #t))))))
|
|
|
|
(define-syntax extract-super
|
|
(syntax-rules ()
|
|
[(_ (mixin base)) (extract-super base)]
|
|
[(_ super) (quote-syntax/loc super)]))
|
|
|
|
(define-syntax extract-app-mixins
|
|
(syntax-rules ()
|
|
[(_ (mixin base)) (cons (quote-syntax/loc mixin) (extract-app-mixins base))]
|
|
[(_ super) null]))
|
|
|
|
(define (flatten-splices l)
|
|
(let loop ([l l])
|
|
(cond [(null? l) null]
|
|
[(splice? (car l)) (append (splice-run (car l)) (loop (cdr l)))]
|
|
[else (cons (car l) (loop (cdr l)))])))
|
|
|
|
(define-syntax-rule (*defclass *include-class link-target? name super (intf ...) body ...)
|
|
(let ([link? link-target?])
|
|
(*include-class
|
|
(syntax-parameterize ([current-class (quote-syntax name)])
|
|
(make-decl (quote-syntax/loc name)
|
|
(extract-super super)
|
|
(extract-app-mixins super)
|
|
(list (quote-syntax/loc intf) ...)
|
|
null
|
|
(lambda (whole-page?)
|
|
(list (*class-doc 'class
|
|
(quote-syntax/loc name)
|
|
(quote-syntax/loc super)
|
|
(list (quote-syntax intf) ...)
|
|
null
|
|
whole-page?
|
|
make-class-index-desc
|
|
link?)))
|
|
(flatten-splices (list body ...))))
|
|
link?)))
|
|
|
|
(define-syntax defclass
|
|
(syntax-rules ()
|
|
[(_ #:link-target? link-target? name super (intf ...) body ...)
|
|
(*defclass *include-class link-target? name super (intf ...) body ...)]
|
|
[(_ name super (intf ...) body ...)
|
|
(defclass #:link-target? #t name super (intf ...) body ...)]))
|
|
|
|
(define-syntax defclass/title
|
|
(syntax-rules ()
|
|
[(_ #:link-target? link-target? name super (intf ...) body ...)
|
|
(*defclass *include-class/title link-target? name super (intf ...) body ...)]
|
|
[(_ name super (intf ...) body ...)
|
|
(defclass/title #:link-target? #t name super (intf ...) body ...)]))
|
|
|
|
(define-syntax-rule (*definterface *include-class name (intf ...) body ...)
|
|
(let ([link? #t])
|
|
(*include-class
|
|
(syntax-parameterize ([current-class (quote-syntax name)])
|
|
(make-decl (quote-syntax/loc name)
|
|
#f
|
|
null
|
|
(list (quote-syntax/loc intf) ...)
|
|
null
|
|
(lambda (whole-page?)
|
|
(list
|
|
(*class-doc 'interface
|
|
(quote-syntax/loc name)
|
|
#f
|
|
(list (quote-syntax intf) ...)
|
|
null
|
|
whole-page?
|
|
make-interface-index-desc
|
|
link?)))
|
|
(list body ...)))
|
|
link?)))
|
|
|
|
(define-syntax-rule (definterface name (intf ...) body ...)
|
|
(*definterface *include-class name (intf ...) body ...))
|
|
|
|
(define-syntax-rule (definterface/title name (intf ...) body ...)
|
|
(*definterface *include-class/title name (intf ...) body ...))
|
|
|
|
(define-syntax-rule (*defmixin *include-class name (domain ...) (range ...)
|
|
body ...)
|
|
(let ([link? #t])
|
|
(*include-class
|
|
(syntax-parameterize ([current-class (quote-syntax name)])
|
|
(make-decl (quote-syntax/loc name)
|
|
#f
|
|
null
|
|
(list (quote-syntax/loc domain) ...)
|
|
(list (quote-syntax/loc range) ...)
|
|
(lambda (whole-page?)
|
|
(list
|
|
(*class-doc 'mixin
|
|
(quote-syntax/loc name)
|
|
#f
|
|
(list (quote-syntax domain) ...)
|
|
(list (quote-syntax range) ...)
|
|
whole-page?
|
|
make-mixin-index-desc
|
|
link?)))
|
|
(list body ...)))
|
|
link?)))
|
|
|
|
(define-syntax-rule (defmixin name (domain ...) (range ...) body ...)
|
|
(*defmixin *include-class name (domain ...) (range ...) body ...))
|
|
|
|
(define-syntax-rule (defmixin/title name (domain ...) (range ...) body ...)
|
|
(*defmixin *include-class/title name (domain ...) (range ...) body ...))
|
|
|
|
(define-syntax (defconstructor*/* stx)
|
|
(syntax-case stx ()
|
|
[(_ mode ((arg ...) ...) desc ...)
|
|
(let ([n (syntax-parameter-value #'current-class)])
|
|
(with-syntax ([name n]
|
|
[result
|
|
(datum->syntax
|
|
#f
|
|
(list
|
|
(datum->syntax #'is-a?/c 'is-a?/c (list 'src 1 1 2 1))
|
|
(datum->syntax n (syntax-e n) (list 'src 1 3 4 1)))
|
|
(list 'src 1 0 1 5))]
|
|
[(((kw ...) ...) ...)
|
|
(map (lambda (ids)
|
|
(map (lambda (arg)
|
|
(if (and (pair? (syntax-e arg))
|
|
(eq? (syntax-e #'mode) 'new))
|
|
(list (string->keyword
|
|
(symbol->string
|
|
(syntax-e
|
|
(car (syntax-e arg))))))
|
|
null))
|
|
(syntax->list ids)))
|
|
(syntax->list #'((arg ...) ...)))])
|
|
#'(make-constructor (lambda ()
|
|
(defproc* #:mode mode #:within name
|
|
[[(make [kw ... . arg] ...) result] ...]
|
|
desc ...)))))]))
|
|
|
|
(define-syntax (defconstructor stx)
|
|
(syntax-case stx ()
|
|
[(_ ([id . arg-rest] ...) desc ...)
|
|
#'(defconstructor*/* new (([id . arg-rest] ...)) desc ...)]))
|
|
|
|
(define-syntax (defconstructor/make stx)
|
|
(syntax-case stx ()
|
|
[(_ ([id . arg-rest] ...) desc ...)
|
|
#'(defconstructor*/* make (([id . arg-rest] ...)) desc ...)]))
|
|
|
|
(define-syntax (defconstructor*/make stx)
|
|
(syntax-case stx ()
|
|
[(_ (([id . arg-rest] ...) ...) desc ...)
|
|
#'(defconstructor*/* make (([id . arg-rest] ...) ...) desc ...)]))
|
|
|
|
(define-syntax (defconstructor/auto-super stx)
|
|
(syntax-case stx ()
|
|
[(_ ([id . arg-rest] ...) desc ...)
|
|
#'(defconstructor*/* new (([id . arg-rest] ... _...superclass-args...))
|
|
desc ...)]))
|
|
|
|
(define-syntax (defmethod* stx)
|
|
(syntax-case stx ()
|
|
[(_ #:mode mode #:link-target? link-target? ([(name arg ...) result-type] ...) desc ...)
|
|
(with-syntax ([cname (syntax-parameter-value #'current-class)]
|
|
[name1 (car (syntax->list #'(name ...)))])
|
|
(with-syntax ([(extra ...)
|
|
(let ([finality
|
|
(lambda (prefix)
|
|
(case (syntax-e #'mode)
|
|
[(override-final public-final extend-final)
|
|
#`(#,prefix "This method is final, so it cannot be overridden.")]
|
|
[(augment-final)
|
|
#`(#,prefix "This method is final, so it cannot be augmented.")]
|
|
[else null]))])
|
|
(case (syntax-e #'mode)
|
|
[(pubment)
|
|
#'((t "Refine this method with "
|
|
(racket augment) "."))]
|
|
[(override
|
|
override-final
|
|
extend
|
|
extend-final
|
|
augment
|
|
augment-final)
|
|
#`((t #,(case (syntax-e #'mode)
|
|
[(override override-final) "Overrides "]
|
|
[(extend extend-final) "Extends "]
|
|
[(augment augment-final) "Augments "])
|
|
(*xmethod/super (quote-syntax/loc cname) 'name1)
|
|
"."
|
|
#,@(finality " ")))]
|
|
[(public public-final) #`((t #,@(finality "")))]
|
|
[else (raise-syntax-error #f "unrecognized mode" #'mode)]))])
|
|
#'(make-meth '(name ...)
|
|
'mode
|
|
(lambda ()
|
|
(defproc* #:link-target? link-target? #:mode send #:within cname
|
|
([(name arg ...) result-type] ...)
|
|
(make-splice
|
|
(append-map (lambda (f)
|
|
(cond [(impl? f) ((impl-def f))]
|
|
[(spec? f) ((spec-def f))]
|
|
[else (list f)]))
|
|
(list extra ... desc ...))))))))]
|
|
[(_ #:mode mode ([(name arg ...) result-type] ...) desc ...)
|
|
#'(defmethod* #:mode mode #:link-target? #t ([(name arg ...) result-type] ...) desc ...)]
|
|
[(_ #:link-target? link-target? ([(name arg ...) result-type] ...) desc ...)
|
|
#'(defmethod* #:mode public #:link-target? link-target? ([(name arg ...) result-type] ...) desc ...)]
|
|
[(_ ([(name arg ...) result-type] ...) desc ...)
|
|
#'(defmethod* #:mode public ([(name arg ...) result-type] ...) desc ...)]))
|
|
|
|
(define-syntax defmethod
|
|
(syntax-rules ()
|
|
[(_ #:mode mode #:link-target? link-target? (name arg ...) result-type desc ...)
|
|
(defmethod* #:mode mode #:link-target? link-target? ([(name arg ...) result-type]) desc ...)]
|
|
[(_ #:mode mode (name arg ...) result-type desc ...)
|
|
(defmethod #:mode mode #:link-target? #t (name arg ...) result-type desc ...)]
|
|
[(_ #:link-target? link-target? (name arg ...) result-type desc ...)
|
|
(defmethod #:mode public #:link-target? link-target? (name arg ...) result-type desc ...)]
|
|
[(_ (name arg ...) result-type desc ...)
|
|
(defmethod #:mode public #:link-target? #t (name arg ...) result-type desc ...)]))
|
|
|
|
(define-syntax-rule (methimpl body ...)
|
|
(make-impl (lambda () (list (italic "Default implementation:") " " body ...))))
|
|
|
|
(define-syntax-rule (methspec body ...)
|
|
(make-spec (lambda () (list (italic "Specification:") " " body ...))))
|
|
|
|
(define (*this-obj cname)
|
|
(name-this-object cname))
|
|
|
|
(define-syntax (this-obj stx)
|
|
(syntax-case stx ()
|
|
[(_)
|
|
(with-syntax ([cname (syntax-parameter-value #'current-class)])
|
|
#'(*this-obj 'cname))]))
|
|
|
|
(define (*xmethod/super cname name)
|
|
(let ([get
|
|
(lambda (d ri key)
|
|
(if key
|
|
(let ([v (lookup-cls/intf d ri key)])
|
|
(if v
|
|
(append (cls/intf-app-mixins v)
|
|
(cons (cls/intf-super v)
|
|
(cls/intf-intfs v)))
|
|
null))
|
|
null))])
|
|
(make-delayed-element
|
|
(lambda (r d ri)
|
|
(let loop ([search (get d ri (find-scheme-tag d ri cname #f))])
|
|
(cond
|
|
[(null? search)
|
|
(list (make-element #f '("<method not found>")))]
|
|
[(not (car search))
|
|
(loop (cdr search))]
|
|
[else
|
|
(let* ([a-key (find-scheme-tag d ri (car search) #f)]
|
|
[v (and a-key (lookup-cls/intf d ri a-key))])
|
|
(if v
|
|
(if (member name (cls/intf-methods v))
|
|
(list
|
|
(make-element #f
|
|
(list (**method name a-key)
|
|
" in "
|
|
(cls/intf-name-element v))))
|
|
(loop (append (cdr search)
|
|
(get d ri (find-scheme-tag d ri (car search)
|
|
#f)))))
|
|
(loop (cdr search))))])))
|
|
(lambda () (format "~a in ~a" (syntax-e cname) name))
|
|
(lambda () (format "~a in ~a" (syntax-e cname) name)))))
|
|
|
|
(define (lookup-cls/intf d ri tag)
|
|
(let ([v (resolve-get d ri `(cls/intf ,(cadr tag)))])
|
|
(or v (make-cls/intf "unknown" null #f null null))))
|