#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"?
(max-proto-width . < . (+ 8
(if (pair? name)
(+ (sym-length (car name))
1
(sym-length (cadr name)))
(sym-length name))
1
(if (pair? fields)
(sym-length (field-name (car fields)))
0)
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))))