#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))))

