d92b1829d5
If a struct has no fields, don't check if a struct's name + first field's name are too long to print on one line Bug report: https://groups.google.com/forum/#!topic/racket-users/6fKGky4tud8
1202 lines
51 KiB
Racket
1202 lines
51 KiB
Racket
#lang racket/base
|
|
(require "../struct.rkt"
|
|
"../scheme.rkt"
|
|
"../basic.rkt"
|
|
"../manual-struct.rkt"
|
|
(only-in "../core.rkt"
|
|
make-style make-table-columns)
|
|
"../html-properties.rkt"
|
|
"qsloc.rkt"
|
|
"manual-utils.rkt"
|
|
"manual-vars.rkt"
|
|
"manual-style.rkt"
|
|
"manual-scheme.rkt"
|
|
"manual-bind.rkt"
|
|
"manual-method.rkt"
|
|
"manual-ex.rkt"
|
|
"on-demand.rkt"
|
|
scheme/string
|
|
scheme/list
|
|
(for-syntax racket/base
|
|
syntax/parse)
|
|
(for-label racket/base
|
|
racket/contract
|
|
racket/class))
|
|
|
|
(provide defproc defproc* defstruct defstruct*
|
|
defparam defparam* defboolparam
|
|
defthing defthing*
|
|
defthing/proc ; XXX unknown contract
|
|
;; private:
|
|
*defthing) ; XXX unknown contract
|
|
|
|
(define-on-demand dots0
|
|
(make-element meta-color (list "...")))
|
|
(define-on-demand dots1
|
|
(make-element meta-color (list "...+")))
|
|
|
|
(define (make-openers n)
|
|
(racketparenfont
|
|
(case n [(1) "("] [(0) ""] [(2) "(("] [else (make-string n #\()])))
|
|
(define (make-closers n)
|
|
(racketparenfont
|
|
(case n [(1) ")"] [(0) ""] [(2) "))"] [else (make-string n #\()])))
|
|
|
|
(define-syntax (arg-contract stx)
|
|
(syntax-case stx (... ...+ _...superclass-args...)
|
|
[(_ [id contract])
|
|
(identifier? #'id)
|
|
#'(racketblock0 contract)]
|
|
[(_ [id contract val])
|
|
(identifier? #'id)
|
|
#'(racketblock0 contract)]
|
|
[(_ [kw id contract])
|
|
(and (keyword? (syntax-e #'kw)) (identifier? #'id))
|
|
#'(racketblock0 contract)]
|
|
[(_ [kw id contract val])
|
|
(and (keyword? (syntax-e #'kw)) (identifier? #'id))
|
|
#'(racketblock0 contract)]
|
|
[(_ (... ...)) #'#f]
|
|
[(_ (... ...+)) #'#f]
|
|
[(_ _...superclass-args...) #'#f]
|
|
[(_ arg) (raise-syntax-error 'defproc "bad argument form" #'arg)]))
|
|
|
|
(define-syntax (arg-default stx)
|
|
(syntax-case stx (... ...+ _...superclass-args...)
|
|
[(_ [id contract])
|
|
(identifier? #'id)
|
|
#'#f]
|
|
[(_ [id contract val])
|
|
(identifier? #'id)
|
|
#'(racketblock0 val)]
|
|
[(_ [kw id contract])
|
|
(keyword? (syntax-e #'kw))
|
|
#'#f]
|
|
[(_ [kw id contract val])
|
|
(keyword? (syntax-e #'kw))
|
|
#'(racketblock0 val)]
|
|
[_ #'#f]))
|
|
|
|
(define-syntax (extract-proc-id stx)
|
|
(syntax-case stx ()
|
|
[(_ k e id)
|
|
(identifier? #'id)
|
|
(if (and (syntax-e #'k)
|
|
(free-identifier=? #'k #'id))
|
|
#'e
|
|
#`(quote-syntax/loc id))]
|
|
[(_ k e (proto arg ...))
|
|
#'(extract-proc-id k e proto)]
|
|
[(_ thing) (raise-syntax-error 'defproc "bad prototype" #'thing)]))
|
|
|
|
(define-syntax (arg-contracts stx)
|
|
(syntax-case stx ()
|
|
[(_ id arg ...)
|
|
(identifier? #'id)
|
|
#'(list (lambda () (arg-contract arg)) ...)]
|
|
[(_ (proto arg1 ...) arg ...)
|
|
#'(arg-contracts proto arg1 ... arg ...)]
|
|
[_ (raise-syntax-error 'defproc "bad prototype" stx)]))
|
|
|
|
(define-syntax (arg-defaults stx)
|
|
(syntax-case stx ()
|
|
[(_ id arg ...)
|
|
(identifier? #'id)
|
|
#'(list (lambda () (arg-default arg)) ...)]
|
|
[(_ (proto arg1 ...) arg ...)
|
|
#'(arg-defaults proto arg1 ... arg ...)]
|
|
[_ (raise-syntax-error 'defproc "bad prototype" stx)]))
|
|
|
|
(define-syntax (result-contract stx)
|
|
(syntax-case stx (values)
|
|
[(_ (values c ...))
|
|
#'(list (racketblock0 c) ...)]
|
|
[(_ c)
|
|
(if (string? (syntax-e #'c))
|
|
(raise-syntax-error 'defproc
|
|
"expected a result contract, found a string" #'c)
|
|
#'(racketblock0 c))]))
|
|
|
|
(define no-value #f)
|
|
|
|
(define-syntax (result-value stx)
|
|
(syntax-case stx (no-value let)
|
|
[(_ no-value) #'#f]
|
|
[(_ (let () e ...)) #'(racketblock0 e ...)]
|
|
[(_ v) #'(racketblock0 v)]))
|
|
|
|
(begin-for-syntax
|
|
(define-splicing-syntax-class kind-kw
|
|
#:description "#:kind keyword"
|
|
(pattern (~optional (~seq #:kind kind)
|
|
#:defaults ([kind #'#f]))))
|
|
|
|
(define-splicing-syntax-class value-kw
|
|
#:description "#:value keyword"
|
|
(pattern (~optional (~seq #:value value)
|
|
#:defaults ([value #'no-value]))))
|
|
|
|
(define-splicing-syntax-class link-target?-kw
|
|
#:description "#:link-target? keyword"
|
|
(pattern (~seq #:link-target? expr))
|
|
(pattern (~seq)
|
|
#:with expr #'#t))
|
|
|
|
(define-syntax-class id-or-false
|
|
(pattern i:id)
|
|
(pattern #f #:with i #'#f))
|
|
|
|
(define-splicing-syntax-class id-kw
|
|
#:description "#:id keyword"
|
|
(pattern (~optional (~seq #:id [key:id-or-false expr])
|
|
#:defaults ([key #'#f]
|
|
[expr #'#f]))))
|
|
|
|
(define-splicing-syntax-class mode-kw
|
|
#:description "#:mode keyword"
|
|
(pattern (~optional (~seq #:mode m:id)
|
|
#:defaults ([m #'procedure]))))
|
|
|
|
(define-splicing-syntax-class within-kw
|
|
#:description "#:within keyword"
|
|
(pattern (~optional (~seq #:within cl:id)
|
|
#:defaults ([cl #'#f]))))
|
|
)
|
|
|
|
(define-syntax (defproc stx)
|
|
(syntax-parse stx
|
|
[(_ kind:kind-kw
|
|
lt:link-target?-kw
|
|
i:id-kw
|
|
(id arg ...)
|
|
result
|
|
value:value-kw
|
|
desc ...)
|
|
(syntax/loc stx
|
|
(defproc*
|
|
#:kind kind.kind
|
|
#:link-target? lt.expr
|
|
#:id [i.key i.expr]
|
|
[[(id arg ...) result #:value value.value]]
|
|
desc ...))]))
|
|
|
|
(define-syntax (defproc* stx)
|
|
(syntax-parse stx
|
|
[(_ kind:kind-kw
|
|
lt:link-target?-kw
|
|
d:id-kw
|
|
mode:mode-kw
|
|
within:within-kw
|
|
[[proto result value:value-kw] ...]
|
|
desc ...)
|
|
(syntax/loc stx
|
|
(with-togetherable-racket-variables
|
|
()
|
|
([proc proto] ...)
|
|
(let ([alt-id d.expr])
|
|
(*defproc kind.kind
|
|
lt.expr
|
|
'mode.m (quote-syntax/loc within.cl)
|
|
(list (extract-proc-id d.key alt-id proto) ...)
|
|
'd.key
|
|
'[proto ...]
|
|
(list (arg-contracts proto) ...)
|
|
(list (arg-defaults proto) ...)
|
|
(list (lambda () (result-contract result)) ...)
|
|
(lambda () (list desc ...))
|
|
(list (result-value value.value) ...)))))]))
|
|
|
|
(define-struct arg
|
|
(special? kw id optional? starts-optional? ends-optional? num-closers))
|
|
|
|
(define (*defproc kind link? mode within-id
|
|
stx-ids sym prototypes arg-contractss arg-valss result-contracts content-thunk
|
|
[result-values (map (lambda (x) #f) result-contracts)])
|
|
(define max-proto-width (current-display-width))
|
|
(define ((arg->elem show-opt-start?) arg)
|
|
(let* ([e (cond [(not (arg-special? arg))
|
|
(if (arg-kw arg)
|
|
(if (eq? mode 'new)
|
|
(make-element
|
|
#f (list (racketparenfont "[")
|
|
(racketidfont (datum-intern-literal (keyword->string (arg-kw arg))))
|
|
spacer
|
|
(to-element (make-var-id (arg-id arg)))
|
|
(racketparenfont "]")))
|
|
(make-element
|
|
#f (list (to-element (arg-kw arg))
|
|
spacer
|
|
(to-element (make-var-id (arg-id arg))))))
|
|
(to-element (make-var-id (arg-id arg))))]
|
|
[(eq? (arg-id arg) '...+) dots1]
|
|
[(eq? (arg-id arg) '...) dots0]
|
|
[(eq? (arg-id arg) '_...superclass-args...) (to-element (arg-id arg))]
|
|
[else (to-element (make-var-id (arg-id arg)))])]
|
|
[e (if (arg-ends-optional? arg)
|
|
(make-element #f (list e "]"))
|
|
e)]
|
|
[e (if (zero? (arg-num-closers arg))
|
|
e
|
|
(make-element
|
|
#f (list e (make-closers (arg-num-closers arg)))))])
|
|
(if (and show-opt-start? (arg-starts-optional? arg))
|
|
(make-element #f (list "[" e))
|
|
e)))
|
|
(define (prototype-depth p)
|
|
(let loop ([p (car p)])
|
|
(if (symbol? p) 0 (+ 1 (loop (car p))))))
|
|
(define (prototype-args p)
|
|
(define (parse-arg v in-optional? depth next-optional? next-special-dots?)
|
|
(let* ([id (if (pair? v) ((if (keyword? (car v)) cadr car) v) v)]
|
|
[kw (and (pair? v) (keyword? (car v)) (car v))]
|
|
[default? (and (pair? v) (pair? ((if kw cdddr cddr) v)))])
|
|
(make-arg (symbol? v) kw id default?
|
|
(and default? (not in-optional?))
|
|
(or (and (not default?)
|
|
in-optional?) ; => must be special
|
|
(and default?
|
|
(not next-optional?)
|
|
(not next-special-dots?)))
|
|
depth)))
|
|
(let loop ([p p] [last-depth 0])
|
|
(append
|
|
(if (symbol? (car p))
|
|
null
|
|
(loop (car p) (add1 last-depth)))
|
|
(let loop ([p (cdr p)][in-optional? #f])
|
|
(cond
|
|
[(null? p) null]
|
|
[(null? (cdr p))
|
|
(list (parse-arg (car p) in-optional? last-depth #f #f))]
|
|
[else
|
|
(let ([a (parse-arg
|
|
(car p)
|
|
in-optional?
|
|
0
|
|
(let ([v (cadr p)])
|
|
(and (pair? v)
|
|
(not
|
|
(null? ((if (keyword? (car v)) cdddr cddr) v)))))
|
|
(and (not (pair? (cadr p)))
|
|
(not (eq? '_...superclass-args... (cadr p)))))])
|
|
(cons a (loop (cdr p)
|
|
(and (arg-optional? a)
|
|
(not (arg-ends-optional? a))))))])))))
|
|
(define (prototype-size args first-combine next-combine special-combine?)
|
|
(let loop ([s args] [combine first-combine])
|
|
(if (null? s)
|
|
0
|
|
(combine
|
|
(loop (cdr s) next-combine)
|
|
(let ([a (car s)])
|
|
(+ (arg-num-closers a)
|
|
(if (arg-special? a)
|
|
(string-length (symbol->string (arg-id a)))
|
|
(+ (if (arg-kw a)
|
|
(+ (if (eq? mode 'new) 2 0)
|
|
(string-length (keyword->string (arg-kw a)))
|
|
3
|
|
(string-length (symbol->string (arg-id a))))
|
|
(string-length (symbol->string (arg-id a))))
|
|
(if (and special-combine?
|
|
(pair? (cdr s))
|
|
(arg-special? (cadr s))
|
|
(not (eq? '_...superclass-args...
|
|
(arg-id (cadr s)))))
|
|
(+ 1 (string-length (symbol->string (arg-id (cadr s)))))
|
|
0)))))))))
|
|
(define (extract-id p stx-id)
|
|
(let loop ([p p])
|
|
(if (symbol? (car p))
|
|
(let ([s (car p)])
|
|
(if (eq? s sym)
|
|
(syntax-e stx-id)
|
|
(car p)))
|
|
(loop (car p)))))
|
|
(define (do-one stx-id prototype args arg-contracts arg-vals result-contract result-value
|
|
first? add-background-label?)
|
|
(let ([names (remq* '(... ...+) (map arg-id args))])
|
|
(unless (= (length names) (length (remove-duplicates names eq?)))
|
|
(error 'defproc "duplicate argument names in prototype for ~s: ~s"
|
|
(syntax->datum stx-id) names)))
|
|
(define tagged
|
|
(cond
|
|
[(or (eq? mode 'new)
|
|
(eq? mode 'make))
|
|
(define content
|
|
(list (if (eq? mode 'new)
|
|
(racket new)
|
|
(racket make-object))))
|
|
(define new-elem
|
|
(if (and first? link?)
|
|
(let* ([target-maker (id-to-target-maker within-id #f)])
|
|
(if target-maker
|
|
(target-maker
|
|
content
|
|
(lambda (ctag)
|
|
(let ([tag (constructor-tag ctag)])
|
|
(make-toc-target-element
|
|
#f
|
|
(list (make-index-element
|
|
#f
|
|
content
|
|
tag
|
|
(list (datum-intern-literal (symbol->string (syntax-e within-id)))
|
|
(if (eq? mode 'new)
|
|
"new"
|
|
"make-object"))
|
|
content
|
|
(with-exporting-libraries
|
|
(lambda (libs)
|
|
(make-constructor-index-desc
|
|
(syntax-e within-id)
|
|
libs ctag)))))
|
|
tag))))
|
|
(car content)))
|
|
(car content)))
|
|
(make-element #f (list new-elem spacer (to-element within-id)))]
|
|
[(eq? mode 'send)
|
|
(make-element
|
|
#f
|
|
(list (racket send) spacer
|
|
(name-this-object (syntax-e within-id)) spacer
|
|
(if (and first? link?)
|
|
(let* ([mname (extract-id prototype stx-id)]
|
|
[target-maker (id-to-target-maker within-id #f)]
|
|
[content (*method mname within-id #:defn? #t)]
|
|
[ref-content (*method mname within-id)])
|
|
(if target-maker
|
|
(target-maker
|
|
content
|
|
(lambda (ctag)
|
|
(let ([tag (method-tag ctag mname)])
|
|
(make-toc-target2-element
|
|
#f
|
|
(list (make-index-element
|
|
#f
|
|
content
|
|
tag
|
|
(list (datum-intern-literal (symbol->string mname)))
|
|
(list ref-content)
|
|
(with-exporting-libraries
|
|
(lambda (libs)
|
|
(make-method-index-desc
|
|
(syntax-e within-id)
|
|
libs mname ctag)))))
|
|
tag
|
|
ref-content))))
|
|
content))
|
|
(*method (extract-id prototype stx-id) within-id #:defn? #t))))]
|
|
[(and first? link?)
|
|
(define the-id (extract-id prototype stx-id))
|
|
(let ([target-maker (id-to-target-maker stx-id #t)])
|
|
(define-values (content ref-content) (definition-site the-id stx-id #f))
|
|
(if target-maker
|
|
(target-maker
|
|
content
|
|
(lambda (tag)
|
|
(make-toc-target2-element
|
|
#f
|
|
(make-index-element
|
|
#f content tag
|
|
(list (datum-intern-literal (symbol->string the-id)))
|
|
(list ref-content)
|
|
(with-exporting-libraries
|
|
(lambda (libs)
|
|
(make-procedure-index-desc the-id libs))))
|
|
tag
|
|
ref-content)))
|
|
content))]
|
|
[else
|
|
(define the-id (extract-id prototype stx-id))
|
|
((if link? annote-exporting-library values)
|
|
(let ([sig (current-signature)])
|
|
(if sig
|
|
(*sig-elem #:defn? #t (sig-id sig) the-id)
|
|
(to-element #:defn? #t (make-just-context the-id stx-id)))))]))
|
|
(define p-depth (prototype-depth prototype))
|
|
(define flat-size (+ (prototype-size args + + #f)
|
|
p-depth
|
|
(element-width tagged)))
|
|
(define short? (or (flat-size . < . 40) ((length args) . < . 2)))
|
|
(define res
|
|
(let ([res (result-contract)])
|
|
(if (list? res)
|
|
;; multiple results
|
|
(if (null? res)
|
|
'nbsp
|
|
(let ([w (apply + (map block-width res))])
|
|
(if (or (ormap table? res) (w . > . 40))
|
|
(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)))
|
|
flow-spacer
|
|
(loop (cdr res))))))))))
|
|
res)))
|
|
(define tagged+arg-width (+ (prototype-size args max max #t)
|
|
p-depth
|
|
(element-width tagged)))
|
|
(define result-next-line?
|
|
((+ (if short? flat-size tagged+arg-width) (block-width res))
|
|
. >= . (- max-proto-width 7)))
|
|
(define end (list flow-spacer (to-flow 'rarr)
|
|
flow-spacer (make-flow (list res))))
|
|
(define (get-label)
|
|
(case mode
|
|
[(new make) "constructor"]
|
|
[(send) "method"]
|
|
[else (or kind "procedure")]))
|
|
(append
|
|
(list
|
|
(list
|
|
((if add-background-label? (add-background-label (get-label)) values)
|
|
(make-flow
|
|
(if short?
|
|
;; The single-line case:
|
|
(top-align
|
|
make-table-if-necessary
|
|
"prototype"
|
|
(list
|
|
(cons
|
|
(to-flow
|
|
(make-element
|
|
#f
|
|
`(,(make-openers (add1 p-depth))
|
|
,tagged
|
|
,@(if (null? args)
|
|
(list (make-closers p-depth))
|
|
(append-map (lambda (arg)
|
|
(list spacer ((arg->elem #t) arg)))
|
|
args))
|
|
,(racketparenfont ")"))))
|
|
(if result-next-line? null end))))
|
|
;; The multi-line case:
|
|
(let ([not-end (if result-next-line?
|
|
(list flow-spacer)
|
|
(list flow-spacer flow-spacer
|
|
flow-spacer flow-spacer))]
|
|
[one-ok? (and (not (eq? mode 'new)) (tagged+arg-width . < . (- max-proto-width 5)))])
|
|
(list
|
|
(top-align
|
|
make-table
|
|
"prototype"
|
|
(cons
|
|
(cons
|
|
(to-flow
|
|
(make-element
|
|
#f
|
|
(list
|
|
(make-openers (add1 p-depth))
|
|
tagged)))
|
|
(if one-ok?
|
|
(list*
|
|
(if (arg-starts-optional? (car args))
|
|
(to-flow (make-element #f (list spacer "[")))
|
|
flow-spacer)
|
|
(to-flow ((arg->elem #f) (car args)))
|
|
not-end)
|
|
(list* 'cont 'cont not-end)))
|
|
(let loop ([args (if one-ok? (cdr args) args)])
|
|
(if (null? args)
|
|
null
|
|
(let ([dots-next?
|
|
(or (and (pair? (cdr args))
|
|
(arg-special? (cadr args))
|
|
(not (eq? '_...superclass-args...
|
|
(arg-id (cadr args))))))])
|
|
(cons
|
|
(list*
|
|
(if (eq? mode 'new)
|
|
(flow-spacer/n 3)
|
|
flow-spacer)
|
|
(if (arg-starts-optional? (car args))
|
|
(to-flow (make-element #f (list spacer "[")))
|
|
flow-spacer)
|
|
(let ([a ((arg->elem #f) (car args))]
|
|
[next (if dots-next?
|
|
(make-element
|
|
#f (list spacer
|
|
((arg->elem #f)
|
|
(cadr args))))
|
|
"")])
|
|
(to-flow
|
|
(cond
|
|
[(null? ((if dots-next? cddr cdr) args))
|
|
(make-element
|
|
#f
|
|
(list a next (racketparenfont ")")))]
|
|
[(equal? next "") a]
|
|
[else
|
|
(make-element #f (list a next))])))
|
|
(if (and (null? ((if dots-next? cddr cdr) args))
|
|
(not result-next-line?))
|
|
end
|
|
not-end))
|
|
(loop ((if dots-next? cddr cdr)
|
|
args)))))))))))))))
|
|
(if result-next-line?
|
|
(list (list (make-flow (top-align
|
|
make-table-if-necessary
|
|
"prototype"
|
|
(list end)))))
|
|
null)
|
|
(append-map
|
|
(lambda (arg arg-contract arg-val)
|
|
(cond
|
|
[(not (arg-special? arg))
|
|
(let* ([arg-cont (arg-contract)]
|
|
[base-len (+ 5 (string-length (symbol->string (arg-id arg)))
|
|
(block-width arg-cont))]
|
|
[arg-val (and arg-val (arg-val))]
|
|
[def-len (if (arg-optional? arg) (block-width arg-val) 0)]
|
|
[base-list
|
|
(list (to-flow (hspace 2))
|
|
(to-flow (to-element (make-var-id (arg-id arg))))
|
|
flow-spacer
|
|
(to-flow ":")
|
|
flow-spacer
|
|
(make-flow (list arg-cont)))])
|
|
(list
|
|
(list
|
|
(make-flow
|
|
(if (and (arg-optional? arg)
|
|
((+ base-len 3 def-len) . >= . max-proto-width))
|
|
(list
|
|
(top-align
|
|
make-table
|
|
"argcontract"
|
|
(list base-list (list flow-spacer flow-spacer flow-spacer
|
|
(to-flow "=") flow-spacer
|
|
(make-flow (list arg-val))))))
|
|
(let ([show-default?
|
|
(and (arg-optional? arg)
|
|
((+ base-len 3 def-len) . < . max-proto-width))])
|
|
(top-align
|
|
make-table-if-necessary
|
|
"argcontract"
|
|
(list
|
|
(append
|
|
base-list
|
|
(if show-default?
|
|
(list flow-spacer (to-flow "=") flow-spacer
|
|
(make-flow (list arg-val)))
|
|
null))))))))))]
|
|
[else null]))
|
|
args
|
|
arg-contracts
|
|
arg-vals)
|
|
(if result-value
|
|
(let ([result-block (if (block? result-value)
|
|
result-value
|
|
(make-omitable-paragraph (list result-value)))])
|
|
(list (list (list (top-align
|
|
make-table
|
|
"argcontract"
|
|
(list (list
|
|
(to-flow (make-element #f (list spacer "=" spacer)))
|
|
(make-flow (list result-block)))))))))
|
|
null)))
|
|
(define all-args (map prototype-args prototypes))
|
|
(define var-list
|
|
(filter-map (lambda (a) (and (not (arg-special? a)) (arg-id a)))
|
|
(append* all-args)))
|
|
(make-box-splice
|
|
(cons
|
|
(make-blockquote
|
|
vertical-inset-style
|
|
(list
|
|
(make-table
|
|
boxed-style
|
|
(append-map
|
|
do-one
|
|
stx-ids prototypes all-args arg-contractss arg-valss result-contracts result-values
|
|
(let loop ([ps prototypes] [stx-ids stx-ids] [accum null])
|
|
(cond [(null? ps) null]
|
|
[(ormap (lambda (a) (eq? (extract-id (car ps) (car stx-ids)) a)) accum)
|
|
(cons #f (loop (cdr ps) (cdr stx-ids) accum))]
|
|
[else (cons #t (loop (cdr ps)
|
|
(cdr stx-ids)
|
|
(cons (extract-id (car ps) (car stx-ids)) accum)))]))
|
|
(for/list ([p (in-list prototypes)]
|
|
[i (in-naturals)])
|
|
(= i 0))))))
|
|
(content-thunk))))
|
|
|
|
(define-syntax (defparam stx)
|
|
(syntax-parse stx
|
|
[(_ lt:link-target?-kw id arg contract value:value-kw desc ...)
|
|
#'(defproc* #:kind "parameter" #:link-target? lt.expr
|
|
([(id) contract] [(id [arg contract]) void? #:value value.value])
|
|
desc ...)]))
|
|
(define-syntax (defparam* stx)
|
|
(syntax-parse stx
|
|
[(_ lt:link-target?-kw id arg in-contract out-contract value:value-kw desc ...)
|
|
#'(defproc* #:kind "parameter" #:link-target? lt.expr
|
|
([(id) out-contract] [(id [arg in-contract]) void? #:value value.value])
|
|
desc ...)]))
|
|
(define-syntax (defboolparam stx)
|
|
(syntax-parse stx
|
|
[(_ lt:link-target?-kw id arg value:value-kw desc ...)
|
|
#'(defproc* #:kind "parameter" #:link-target? lt.expr
|
|
([(id) boolean?] [(id [arg any/c]) void? #:value value.value])
|
|
desc ...)]))
|
|
|
|
(define top-align-styles (make-hash))
|
|
(define (top-align make-table style-name cols)
|
|
(if (null? cols)
|
|
(make-table style-name null)
|
|
(let* ([n (length (car cols))]
|
|
[k (cons style-name n)])
|
|
(make-table
|
|
(hash-ref top-align-styles
|
|
k
|
|
(lambda ()
|
|
(define s
|
|
(make-style style-name
|
|
(list (make-table-columns (for/list ([i n])
|
|
(make-style #f '(top)))))))
|
|
(hash-set! top-align-styles k s)
|
|
s))
|
|
cols))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(begin-for-syntax
|
|
(define-splicing-syntax-class mutable-kw
|
|
#:description "#:mutable keyword"
|
|
(pattern (~seq #:mutable)
|
|
#:with immutable? #'#f)
|
|
(pattern (~seq)
|
|
#:with immutable? #'#t))
|
|
|
|
(define-splicing-syntax-class opacity-kw
|
|
#:description "#:prefab, #:transparent, or #:inspector keyword"
|
|
(pattern (~seq #:prefab)
|
|
#:with opacity #''prefab)
|
|
(pattern (~seq #:transparent)
|
|
#:with opacity #''transparent)
|
|
(pattern (~seq #:inspector #f)
|
|
#:with opacity #''transparent)
|
|
(pattern (~seq)
|
|
#:with opacity #''opaque))
|
|
|
|
(define-splicing-syntax-class constructor-kw
|
|
#:description "#:constructor-name, #:extra-constructor-name, or #:omit-constructor keyword"
|
|
(pattern (~seq #:constructor-name id)
|
|
#:with omit? #'#f
|
|
#:with given? #'#t
|
|
#:with extra? #'#f)
|
|
(pattern (~seq #:extra-constructor-name id)
|
|
#:with omit? #'#f
|
|
#:with given? #'#t
|
|
#:with extra? #'#t)
|
|
(pattern (~seq #:omit-constructor)
|
|
#:with omit? #'#t
|
|
#:with id #'#f
|
|
#:with given? #'#f
|
|
#:with extra? #'#f)
|
|
(pattern (~seq)
|
|
#:with omit? #'#f
|
|
#:with id #'#f
|
|
#:with given? #'#f
|
|
#:with extra? #'#f)))
|
|
|
|
(define-syntax-rule (define-defstruct defstruct default-extra?)
|
|
(...
|
|
(define-syntax (defstruct stx)
|
|
(syntax-parse stx
|
|
[(_ lt:link-target?-kw name fields
|
|
m:mutable-kw o:opacity-kw c:constructor-kw
|
|
desc ...)
|
|
#`(**defstruct lt.expr name fields
|
|
m.immutable? o.opacity
|
|
c.id c.given? c.extra? default-extra? c.omit?
|
|
desc ...)]))))
|
|
|
|
(define-defstruct defstruct #t)
|
|
(define-defstruct defstruct* #f)
|
|
|
|
(define-syntax-rule (**defstruct link? name ([field field-contract] ...)
|
|
immutable? opacity
|
|
cname cname-given? extra-cname? default-extra? omit-constructor?
|
|
desc ...)
|
|
(with-togetherable-racket-variables
|
|
()
|
|
()
|
|
(*defstruct link? (quote-syntax/loc name) 'name
|
|
(quote-syntax/loc cname) cname-given? extra-cname? default-extra? omit-constructor?
|
|
'([field field-contract] ...)
|
|
(list (lambda () (racketblock0 field-contract)) ...)
|
|
immutable? opacity
|
|
(lambda () (list desc ...)))))
|
|
|
|
(define (*defstruct link? stx-id name
|
|
alt-cname-id cname-given? extra-cname? default-extra? omit-constructor?
|
|
fields field-contracts
|
|
immutable? opacity
|
|
content-thunk)
|
|
(define transparent? (or (eq? opacity 'transparent)
|
|
(eq? opacity 'prefab)))
|
|
(define prefab? (eq? opacity 'prefab))
|
|
(define max-proto-width (current-display-width))
|
|
(define (field-name f) ((if (pair? (car f)) caar car) f))
|
|
(define (field-view f)
|
|
(if (pair? (car f)) (make-shaped-parens (car f) #\[) (car f)))
|
|
(define cname-id
|
|
(cond
|
|
[omit-constructor? #f]
|
|
[(identifier? alt-cname-id) alt-cname-id]
|
|
[(not default-extra?) #f]
|
|
[else (let ([name-id (if (identifier? stx-id)
|
|
stx-id
|
|
(car (syntax-e stx-id)))])
|
|
(datum->syntax name-id
|
|
(string->symbol (format "make-~a" (syntax-e name-id)))
|
|
name-id
|
|
name-id))]))
|
|
(define keyword-modifiers? (or (not immutable?)
|
|
transparent?
|
|
cname-id))
|
|
(define keyword-spacer (hspace 4)) ; 2 would match DrRacket indentation, but 4 looks better with field contracts after
|
|
(define main-table
|
|
(make-table
|
|
boxed-style
|
|
(append
|
|
;; First line in "boxed" table is struct name and fields:
|
|
(list
|
|
(list
|
|
((add-background-label "struct")
|
|
(list
|
|
(let* ([the-name
|
|
(let ([just-name
|
|
(let ([name-id (if (pair? name)
|
|
(make-just-context (car name)
|
|
(car (syntax-e stx-id)))
|
|
stx-id)])
|
|
(if link?
|
|
(let ()
|
|
(define (gen defn?)
|
|
((if defn? annote-exporting-library values)
|
|
(to-element #:defn? defn? name-id)))
|
|
(define content (gen #t))
|
|
(define ref-content (gen #f))
|
|
(make-target-element*
|
|
(lambda (s c t)
|
|
(make-toc-target2-element s c t ref-content))
|
|
(if (pair? name)
|
|
(car (syntax-e stx-id))
|
|
stx-id)
|
|
content
|
|
(let ([name (if (pair? name) (car name) name)])
|
|
(list* (list 'info name)
|
|
(list 'type 'struct: name)
|
|
(list 'predicate name '?)
|
|
(append
|
|
(if cname-id
|
|
(list (list 'constructor (syntax-e cname-id)))
|
|
null)
|
|
(map (lambda (f)
|
|
(list 'accessor name '-
|
|
(field-name f)))
|
|
fields)
|
|
(filter-map
|
|
(lambda (f)
|
|
(if (or (not immutable?)
|
|
(and (pair? (car f))
|
|
(memq '#:mutable
|
|
(car f))))
|
|
(list 'mutator 'set- name '-
|
|
(field-name f) '!)
|
|
#f))
|
|
fields))))))
|
|
(to-element #:defn? #t name-id)))])
|
|
(if (pair? name)
|
|
(make-element
|
|
#f
|
|
(list just-name
|
|
(hspace 1)
|
|
(to-element
|
|
(make-just-context
|
|
(cadr name)
|
|
(cadr (syntax-e stx-id))))))
|
|
just-name))]
|
|
[sym-length (lambda (s)
|
|
(string-length (symbol->string s)))]
|
|
[short-width
|
|
(apply +
|
|
(length fields) ; spaces between field names
|
|
8 ; "struct" + "(" + ")"
|
|
(append
|
|
(map sym-length
|
|
(append (if (pair? name) name (list name))
|
|
(map field-name fields)))
|
|
(map (lambda (f)
|
|
(if (pair? (car f))
|
|
(+ 3 2 (string-length (keyword->string
|
|
(cadar f))))
|
|
0))
|
|
fields)))])
|
|
(if (and (short-width . < . max-proto-width)
|
|
(not keyword-modifiers?))
|
|
;; All on one line:
|
|
(make-omitable-paragraph
|
|
(list
|
|
(to-element
|
|
`(,(racket struct)
|
|
,the-name
|
|
,(map field-view fields)))))
|
|
;; Multi-line view (leaving out last paren if keywords follow):
|
|
(let* ([one-right-column?
|
|
;; Does the struct name and fields fit on a single line?
|
|
(or (null? fields)
|
|
(short-width . < . max-proto-width))]
|
|
[split-field-line?
|
|
;; start fields on the line after "struct"?
|
|
(and (pair? fields)
|
|
(max-proto-width . < . (+ 8
|
|
(if (pair? name)
|
|
(+ (sym-length (car name))
|
|
1
|
|
(sym-length (cadr name)))
|
|
(sym-length name))
|
|
1
|
|
(sym-length (field-name (car fields)))
|
|
1)))])
|
|
(make-table
|
|
#f
|
|
;; First four columns: "(struct" <space> <name><space> (
|
|
;; If all fields on the first line, extra columns follow;
|
|
;; If only first field on same line, filds are in fourth column
|
|
;; If no field is on the first line, no fourth column after all
|
|
;; and fields are in the second column
|
|
(append
|
|
(list
|
|
(append
|
|
(list (to-flow (make-element #f
|
|
(list
|
|
(racketparenfont "(")
|
|
(racket struct))))
|
|
flow-spacer)
|
|
(if one-right-column?
|
|
;; struct name and fields on one line:
|
|
(list (to-flow (list the-name
|
|
spacer
|
|
(to-element (map field-view
|
|
fields))
|
|
(if (and immutable?
|
|
(not transparent?)
|
|
(not cname-id))
|
|
(racketparenfont ")")
|
|
null))))
|
|
(if split-field-line?
|
|
;; Field start on line after "struct":
|
|
(list (to-flow (make-element 'no-break the-name)))
|
|
;; First field on the same line as "struct":
|
|
(list (to-flow (make-element 'no-break the-name))
|
|
(to-flow (make-element
|
|
#f (list spacer (racketparenfont "("))))
|
|
(to-flow (make-element 'no-break
|
|
(let ([f (to-element (field-view (car fields)))])
|
|
(if (null? (cdr fields))
|
|
(list f (racketparenfont ")"))
|
|
f)))))))))
|
|
(if split-field-line?
|
|
;; First field, which starts on the next line:
|
|
(list
|
|
(list flow-spacer flow-spacer
|
|
(to-flow (list
|
|
(racketparenfont "(")
|
|
(make-element 'no-break
|
|
(let ([f (to-element (field-view (car fields)))])
|
|
(if (null? (cdr fields))
|
|
(list f (racketparenfont ")"))
|
|
f)))))))
|
|
null)
|
|
;; Remaining fields:
|
|
(if one-right-column?
|
|
null
|
|
(let loop ([fields (if (null? fields)
|
|
fields
|
|
(cdr fields))])
|
|
(if (null? fields)
|
|
null
|
|
(cons
|
|
(let ([fld (car fields)])
|
|
(append
|
|
(list flow-spacer flow-spacer)
|
|
(if split-field-line? null (list flow-spacer flow-spacer))
|
|
(list (to-flow
|
|
(list
|
|
(if split-field-line? spacer null)
|
|
(let ([e (to-element (field-view fld))])
|
|
(if (null? (cdr fields))
|
|
(list e
|
|
(racketparenfont
|
|
(if (and immutable?
|
|
(not transparent?)
|
|
(not cname-id))
|
|
"))"
|
|
")")))
|
|
e)))))))
|
|
(loop (cdr fields)))))))))))))))
|
|
;; Next lines at "boxed" level are construct-name keywords:
|
|
(if cname-id
|
|
(let ([kw (to-element (if (if cname-given?
|
|
extra-cname?
|
|
default-extra?)
|
|
'#:extra-constructor-name
|
|
'#:constructor-name))]
|
|
[nm (to-element cname-id)]
|
|
[close? (and immutable?
|
|
(not transparent?))])
|
|
(if (max-proto-width . < . (+ (element-width keyword-spacer)
|
|
1 ; space between kw & name
|
|
(element-width kw)
|
|
(element-width nm)
|
|
(if close? 1 0)))
|
|
;; use two lines for #:constructor-name
|
|
(list (list (to-flow (list keyword-spacer kw)))
|
|
(list (to-flow
|
|
(list
|
|
keyword-spacer
|
|
(if close?
|
|
(make-element #f (list nm (racketparenfont ")")))
|
|
nm)))))
|
|
;; use one line for #:constructor-name
|
|
(list (list
|
|
(to-flow (make-element
|
|
#f
|
|
(list
|
|
keyword-spacer
|
|
kw (hspace 1) nm
|
|
(if close?
|
|
(racketparenfont ")")
|
|
null))))))))
|
|
null)
|
|
;; Next lines at "boxed" level are prefab/transparent/mutable
|
|
(cond
|
|
[(and (not immutable?) transparent?)
|
|
(list
|
|
(list (to-flow (list keyword-spacer (to-element '#:mutable))))
|
|
(list (to-flow (list keyword-spacer
|
|
(if prefab?
|
|
(to-element '#:prefab)
|
|
(to-element '#:transparent))
|
|
(racketparenfont ")")))))]
|
|
[(not immutable?)
|
|
(list
|
|
(list (to-flow (list keyword-spacer
|
|
(to-element '#:mutable)
|
|
(racketparenfont ")")))))]
|
|
[transparent?
|
|
(list
|
|
(list (to-flow (list keyword-spacer
|
|
(if prefab?
|
|
(to-element '#:prefab)
|
|
(to-element '#:transparent))
|
|
(racketparenfont ")")))))]
|
|
[else null])
|
|
;; Remaining lines at "boxed" level are field contracts:
|
|
(map (lambda (v field-contract)
|
|
(cond
|
|
[(pair? v)
|
|
(list
|
|
(top-align
|
|
make-table-if-necessary
|
|
"argcontract"
|
|
(list (list (to-flow (hspace 2))
|
|
(to-flow (to-element (field-name v)))
|
|
flow-spacer
|
|
(to-flow ":")
|
|
flow-spacer
|
|
(make-flow (list (field-contract)))))))]
|
|
[else null]))
|
|
fields field-contracts))))
|
|
(make-box-splice
|
|
(cons
|
|
(make-blockquote
|
|
vertical-inset-style
|
|
(list main-table))
|
|
(content-thunk))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-syntax (defthing stx)
|
|
(syntax-parse stx
|
|
[(_ kind:kind-kw
|
|
lt:link-target?-kw
|
|
(~optional (~seq #:id id-expr)
|
|
#:defaults ([id-expr #'#f]))
|
|
id
|
|
result
|
|
value:value-kw
|
|
desc ...)
|
|
#'(with-togetherable-racket-variables
|
|
()
|
|
()
|
|
(*defthing kind.kind
|
|
lt.expr
|
|
(list (or id-expr (quote-syntax/loc id))) (list 'id) #f
|
|
(list (racketblock0 result))
|
|
(lambda () (list desc ...))
|
|
(list (result-value value.value))))]))
|
|
|
|
(define-syntax (defthing* stx)
|
|
(syntax-parse stx
|
|
[(_ kind:kind-kw lt:link-target?-kw ([id result value:value-kw] ...) desc ...)
|
|
#'(with-togetherable-racket-variables
|
|
()
|
|
()
|
|
(*defthing kind.kind
|
|
lt.expr
|
|
(list (quote-syntax/loc id) ...) (list 'id ...) #f
|
|
(list (racketblock0 result) ...)
|
|
(lambda () (list desc ...))
|
|
(list (result-value value.value) ...)))]))
|
|
|
|
(define (*defthing kind link? stx-ids names form? result-contracts content-thunk
|
|
[result-values (map (lambda (x) #f) result-contracts)])
|
|
(define max-proto-width (current-display-width))
|
|
(make-box-splice
|
|
(cons
|
|
(make-blockquote
|
|
vertical-inset-style
|
|
(list
|
|
(make-table
|
|
boxed-style
|
|
(append*
|
|
(for/list ([stx-id (in-list stx-ids)]
|
|
[name (in-list names)]
|
|
[result-contract (in-list result-contracts)]
|
|
[result-value (in-list result-values)]
|
|
[i (in-naturals)])
|
|
(let* ([result-block
|
|
(and result-value
|
|
(if (block? result-value)
|
|
result-value
|
|
(make-omitable-paragraph (list result-value))))]
|
|
[contract-block
|
|
(if (block? result-contract)
|
|
result-contract
|
|
(make-omitable-paragraph (list result-contract)))]
|
|
[name+contract-width (+ (string-length (format "~a" name))
|
|
3
|
|
(block-width contract-block))]
|
|
[total-width (+ name+contract-width
|
|
(if result-block
|
|
(+ (block-width result-block) 3)
|
|
0))]
|
|
[thing-id (let ([target-maker
|
|
(and link?
|
|
((if form? id-to-form-target-maker id-to-target-maker)
|
|
stx-id #t))])
|
|
(define-values (content ref-content)
|
|
(if link?
|
|
(definition-site name stx-id form?)
|
|
(let ([s (make-just-context name stx-id)])
|
|
(values (to-element #:defn? #t s)
|
|
(to-element s)))))
|
|
(if target-maker
|
|
(target-maker
|
|
content
|
|
(lambda (tag)
|
|
(make-toc-target2-element
|
|
#f
|
|
(make-index-element
|
|
#f
|
|
content
|
|
tag
|
|
(list (datum-intern-literal (symbol->string name)))
|
|
(list ref-content)
|
|
(with-exporting-libraries
|
|
(lambda (libs) (make-thing-index-desc name libs))))
|
|
tag
|
|
ref-content)))
|
|
content))]
|
|
[contract-on-first-line? (name+contract-width . < . max-proto-width)]
|
|
[single-line? (and contract-on-first-line?
|
|
(total-width . < . max-proto-width)
|
|
(not (table? result-value)))])
|
|
(append
|
|
(list
|
|
(list
|
|
((if (zero? i) (add-background-label (or kind "value")) values)
|
|
(top-align
|
|
make-table-if-necessary
|
|
"argcontract"
|
|
(append
|
|
(list
|
|
(append
|
|
(list (list (make-omitable-paragraph
|
|
(list thing-id))))
|
|
(if contract-on-first-line?
|
|
(list
|
|
(to-flow (list spacer ":" spacer))
|
|
(list contract-block))
|
|
null)
|
|
(if (and result-block single-line?)
|
|
(list
|
|
(to-flow (list spacer "=" spacer))
|
|
(list result-block))
|
|
null))))))))
|
|
(if contract-on-first-line?
|
|
null
|
|
(list (list (top-align
|
|
make-table-if-necessary
|
|
"argcontract"
|
|
(list
|
|
(list (to-flow (list spacer ":" spacer))
|
|
(list contract-block)))))))
|
|
(if (or single-line? (not result-block))
|
|
null
|
|
(list (list (top-align
|
|
make-table-if-necessary
|
|
"argcontract"
|
|
(list (list
|
|
(to-flow (list spacer "=" spacer))
|
|
(list result-block))))))))))))))
|
|
(content-thunk))))
|
|
|
|
(define (defthing/proc kind id contract descs)
|
|
(*defthing kind #t (list id) (list (syntax-e id)) #f (list contract)
|
|
(lambda () descs)))
|
|
|
|
(define (make-target-element* inner-make-target-element stx-id content wrappers)
|
|
(if (null? wrappers)
|
|
content
|
|
(make-target-element*
|
|
make-target-element
|
|
stx-id
|
|
(let* ([name (datum-intern-literal (string-append* (map symbol->string (cdar wrappers))))]
|
|
[target-maker
|
|
(id-to-target-maker (datum->syntax stx-id (string->symbol name))
|
|
#t)])
|
|
(if target-maker
|
|
(target-maker
|
|
content
|
|
(lambda (tag)
|
|
(inner-make-target-element
|
|
#f
|
|
(make-index-element
|
|
#f
|
|
content
|
|
tag
|
|
(list name)
|
|
(list (racketidfont (make-element value-link-color
|
|
(list name))))
|
|
(with-exporting-libraries
|
|
(lambda (libs)
|
|
(let ([name (string->symbol name)])
|
|
(if (eq? 'info (caar wrappers))
|
|
(make-struct-index-desc name libs)
|
|
(make-procedure-index-desc name libs))))))
|
|
tag)))
|
|
content))
|
|
(cdr wrappers))))
|
|
|