experiment with a more contract-like form for docs
svn: r6569 original commit: 4f3afd9c75b9d4f8ee115884b94a583881e7171a
This commit is contained in:
Matthew Flatt
parent
0ae283cd18
commit
893d7d9098
|
|
@ -136,7 +136,8 @@
|
|||
(define/override (render-element e part ht)
|
||||
(cond
|
||||
[(target-element? e)
|
||||
`((a ((name ,(target-element-tag e))) ,@(render-plain-element e part ht)))]
|
||||
`((a ((name ,(target-element-tag e))))
|
||||
,@(render-plain-element e part ht))]
|
||||
[(and (link-element? e)
|
||||
(not (current-no-links)))
|
||||
(parameterize ([current-no-links #t])
|
||||
|
|
|
|||
|
|
@ -17,9 +17,11 @@
|
|||
|
||||
(define-code schemeblock0 to-paragraph)
|
||||
(define-code schemeblock (to-paragraph/prefix (hspace 2)
|
||||
(hspace 2)))
|
||||
(hspace 2)
|
||||
""))
|
||||
(define-code SCHEMEBLOCK (to-paragraph/prefix (hspace 2)
|
||||
(hspace 2))
|
||||
(hspace 2)
|
||||
"")
|
||||
UNSYNTAX)
|
||||
(define-code SCHEMEBLOCK0 to-paragraph UNSYNTAX)
|
||||
(define-code schemeinput (to-paragraph/prefix (make-element
|
||||
|
|
@ -27,7 +29,8 @@
|
|||
(list
|
||||
(hspace 2)
|
||||
(make-element 'tt (list "> " ))))
|
||||
(hspace 4)))
|
||||
(hspace 4)
|
||||
""))
|
||||
|
||||
(define-syntax (schememod stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -161,45 +164,75 @@
|
|||
(define dots1
|
||||
(make-element #f (list "..." (superscript "+"))))
|
||||
|
||||
(define (to-paragraph/suffix s)
|
||||
(to-paragraph/prefix ""
|
||||
""
|
||||
(schemeparenfont s)))
|
||||
|
||||
(define-code schemeblock0/close (to-paragraph/suffix ")"))
|
||||
(define-code schemeblock0/close... (to-paragraph/suffix ") ..."))
|
||||
(define-code schemeblock0/close...+ (to-paragraph/suffix ") ...+"))
|
||||
(define-code schemeblock0/closeclose (to-paragraph/suffix "))"))
|
||||
(define-code schemeblock0/close...close (to-paragraph/suffix ") ...)"))
|
||||
(define-code schemeblock0/close...+close (to-paragraph/suffix ") ...+)"))
|
||||
|
||||
(define-syntax (arg-contract stx)
|
||||
(syntax-case stx (... ...+)
|
||||
[(_ [id contract])
|
||||
[(_ [id contract] typeset)
|
||||
(identifier? #'id)
|
||||
#'(schemeblock0 contract)]
|
||||
[(_ [id contract val])
|
||||
#'(typeset contract)]
|
||||
[(_ [id contract val] typeset)
|
||||
(identifier? #'id)
|
||||
#'(schemeblock0 contract)]
|
||||
[(_ [kw id contract])
|
||||
#'(typeset contract)]
|
||||
[(_ [kw id contract] typeset)
|
||||
(and (keyword? (syntax-e #'kw))
|
||||
(identifier? #'id))
|
||||
#'(schemeblock0 contract)]
|
||||
[(_ [kw id contract val])
|
||||
#'(typeset contract)]
|
||||
[(_ [kw id contract val] typeset)
|
||||
(and (keyword? (syntax-e #'kw))
|
||||
(identifier? #'id))
|
||||
#'(schemeblock0 contract)]
|
||||
[(_ (... ...))
|
||||
#'(typeset contract)]
|
||||
[(_ (... ...) typeset)
|
||||
#'#f]
|
||||
[(_ (... ...+))
|
||||
[(_ (... ...+) typeset)
|
||||
#'#f]
|
||||
[(_ arg)
|
||||
[(_ arg typeset)
|
||||
(raise-syntax-error
|
||||
'defproc
|
||||
"bad argument form"
|
||||
#'arg)]))
|
||||
|
||||
|
||||
(define-syntax arg-contracts
|
||||
(syntax-rules (... ...+)
|
||||
[(_) null]
|
||||
[(_ arg (... ...))
|
||||
(list (lambda () (arg-contract arg schemeblock0/close...close)))]
|
||||
[(_ arg (... ...+))
|
||||
(list (lambda () (arg-contract arg schemeblock0/close...+close)))]
|
||||
[(_ arg (... ...) . rest)
|
||||
(cons (lambda () (arg-contract arg schemeblock0/close...))
|
||||
(arg-contracts . rest))]
|
||||
[(_ arg (... ...+) . rest)
|
||||
(cons (lambda () (arg-contract arg schemeblock0/close...+))
|
||||
(arg-contracts . rest))]
|
||||
[(_ arg)
|
||||
(list (lambda () (arg-contract arg schemeblock0/closeclose)))]
|
||||
[(_ arg . rest)
|
||||
(cons (lambda () (arg-contract arg schemeblock0/close))
|
||||
(arg-contracts . rest))]))
|
||||
|
||||
(define-syntax defproc
|
||||
(syntax-rules ()
|
||||
[(_ (id arg ...) result desc ...)
|
||||
(*defproc '[(id arg ...)]
|
||||
(list (list (lambda () (arg-contract arg)) ...))
|
||||
(list (arg-contracts arg ...))
|
||||
(list (lambda () (schemeblock0 result)))
|
||||
(lambda () (list desc ...)))]))
|
||||
(define-syntax defproc*
|
||||
(syntax-rules ()
|
||||
[(_ [[(id arg ...) result] ...] desc ...)
|
||||
(*defproc '[(id arg ...) ...]
|
||||
(list (list (lambda () (arg-contract arg)) ...) ...)
|
||||
(list (arg-contracts arg ...) ...)
|
||||
(list (lambda () (schemeblock0 result)) ...)
|
||||
(lambda () (list desc ...)))]))
|
||||
(define-syntax defstruct
|
||||
|
|
@ -282,20 +315,7 @@
|
|||
3
|
||||
2))))]
|
||||
[to-flow (lambda (e)
|
||||
(make-flow (list (make-paragraph (list e)))))]
|
||||
[arg->elem (lambda (v)
|
||||
(cond
|
||||
[(pair? v)
|
||||
(if (keyword? (car v))
|
||||
(make-element #f (list (to-element (car v))
|
||||
(hspace 1)
|
||||
(to-element (cadr v))))
|
||||
(to-element (car v)))]
|
||||
[(eq? v '...+)
|
||||
dots1]
|
||||
[(eq? v '...)
|
||||
dots0]
|
||||
[else v]))])
|
||||
(make-flow (list (make-paragraph (list e)))))])
|
||||
(parameterize ([current-variable-list
|
||||
(map (lambda (i)
|
||||
(and (pair? i)
|
||||
|
|
@ -307,86 +327,97 @@
|
|||
(cons
|
||||
(make-table
|
||||
'boxed
|
||||
(apply
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (prototype arg-contracts result-contract first?)
|
||||
(append
|
||||
(list
|
||||
(list (make-flow
|
||||
(list
|
||||
(make-table
|
||||
'((valignment top top top top top))
|
||||
(list
|
||||
(list
|
||||
(to-flow
|
||||
(let-values ([(required optional more-required)
|
||||
(let loop ([a (cdr prototype)][r-accum null])
|
||||
(if (or (null? a)
|
||||
(and (has-optional? (car a))))
|
||||
(let ([req (reverse r-accum)])
|
||||
(let loop ([a a][o-accum null])
|
||||
(if (or (null? a)
|
||||
(not (has-optional? (car a))))
|
||||
(values req (reverse o-accum) a)
|
||||
(loop (cdr a) (cons (car a) o-accum)))))
|
||||
(loop (cdr a) (cons (car a) r-accum))))])
|
||||
(to-element (append
|
||||
(list (if first?
|
||||
(make-target-element
|
||||
#f
|
||||
(list (to-element (car prototype)))
|
||||
(register-scheme-definition (car prototype)))
|
||||
(to-element (car prototype))))
|
||||
(map arg->elem required)
|
||||
(if (null? optional)
|
||||
null
|
||||
(list
|
||||
(to-element
|
||||
(syntax-property
|
||||
(syntax-ize (map arg->elem optional) 0)
|
||||
'paren-shape
|
||||
#\?))))
|
||||
(map arg->elem more-required)))))
|
||||
(to-flow spacer)
|
||||
(to-flow 'rarr)
|
||||
(to-flow spacer)
|
||||
(make-flow (list (result-contract))))))))))
|
||||
(apply append
|
||||
(map (lambda (v arg-contract)
|
||||
(cond
|
||||
[(pair? v)
|
||||
(list
|
||||
(list
|
||||
(make-flow
|
||||
(list
|
||||
(make-table
|
||||
`((valignment baseline baseline baseline baseline
|
||||
baseline baseline
|
||||
,@(if (has-optional? v)
|
||||
'(baseline baseline baseline baseline)
|
||||
null)))
|
||||
(list
|
||||
(let ([v (if (keyword? (car v))
|
||||
(cdr v)
|
||||
v)])
|
||||
(append
|
||||
(let ([name (if first?
|
||||
(make-target-element
|
||||
#f
|
||||
(list (to-element (car prototype)))
|
||||
(register-scheme-definition (car prototype)))
|
||||
(to-element (car prototype)))])
|
||||
(list
|
||||
(list
|
||||
(make-flow
|
||||
(list
|
||||
(if (null? (cdr prototype))
|
||||
(make-table
|
||||
#f
|
||||
(list (list
|
||||
(make-flow
|
||||
(list
|
||||
(make-paragraph
|
||||
(list (schemeparenfont "(")
|
||||
name
|
||||
(schemeparenfont ")"))))))))
|
||||
(make-table
|
||||
#f
|
||||
(let loop ([args (cdr prototype)]
|
||||
[arg-contracts arg-contracts]
|
||||
[first? #t])
|
||||
(let* ([a (car args)]
|
||||
[v (if (keyword? (car a))
|
||||
(cdr a)
|
||||
a)]
|
||||
[dots (and (pair? (cdr args))
|
||||
(not (pair? (cadr args)))
|
||||
(cadr args))])
|
||||
(cons
|
||||
(list (if first?
|
||||
(make-flow
|
||||
(list
|
||||
(make-paragraph
|
||||
(list
|
||||
(schemeparenfont "(")
|
||||
name
|
||||
spacer))))
|
||||
(to-flow spacer))
|
||||
(make-flow
|
||||
(list
|
||||
(make-table
|
||||
'((valignment baseline baseline baseline))
|
||||
(list
|
||||
(list
|
||||
(to-flow (hspace 2))
|
||||
(to-flow (arg->elem v))
|
||||
(make-flow
|
||||
(list
|
||||
(make-paragraph
|
||||
(append
|
||||
(list (schemeparenfont "("))
|
||||
(if (keyword? (car a))
|
||||
(list (to-element (car a)) spacer)
|
||||
null)
|
||||
(list (schemefont " "))
|
||||
(if (has-optional? a)
|
||||
(list (schemeparenfont "["))
|
||||
null)
|
||||
(list (to-element (car v)))
|
||||
(if (has-optional? a)
|
||||
(list spacer
|
||||
(to-element (caddr v))
|
||||
(schemeparenfont "]"))
|
||||
null)))))
|
||||
(to-flow spacer)
|
||||
(to-flow ":")
|
||||
(to-flow spacer)
|
||||
(make-flow (list (arg-contract))))
|
||||
(if (has-optional? v)
|
||||
(list (to-flow spacer)
|
||||
(to-flow "=")
|
||||
(to-flow spacer)
|
||||
(to-flow (to-element (caddr v))))
|
||||
null)))))))))]
|
||||
[else null]))
|
||||
(cdr prototype)
|
||||
arg-contracts))))
|
||||
(make-flow
|
||||
;; Note: arg-contract includes closing paren for arg,
|
||||
;; as well as dots or closing paren for arg sequence
|
||||
(list ((car arg-contracts))))))))))
|
||||
(let ([next (if dots
|
||||
(cddr args)
|
||||
(cdr args))])
|
||||
(if (null? next)
|
||||
null
|
||||
(loop next
|
||||
((if dots cddr cdr) arg-contracts)
|
||||
#f)))))))))))
|
||||
(list
|
||||
(make-flow
|
||||
(list
|
||||
(make-table
|
||||
#f
|
||||
(list (list (to-flow spacer)
|
||||
(to-flow spacer)
|
||||
(make-flow (list (result-contract))))))))))))
|
||||
prototypes
|
||||
arg-contractss
|
||||
result-contracts
|
||||
|
|
@ -465,8 +496,11 @@
|
|||
(list (make-target-element
|
||||
#f
|
||||
(list (to-element name))
|
||||
(register-scheme-definition name))
|
||||
spacer ":" spacer
|
||||
(register-scheme-definition name)))))))
|
||||
(list (make-flow
|
||||
(list
|
||||
(make-paragraph
|
||||
(list spacer spacer
|
||||
(to-element result-contract))))))))
|
||||
(content-thunk))))
|
||||
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@
|
|||
|
||||
(define-struct (sized-element element) (length))
|
||||
|
||||
(define (typeset c multi-line? prefix1 prefix color?)
|
||||
(define (typeset c multi-line? prefix1 prefix suffix color?)
|
||||
(let* ([c (syntax-ize c 0)]
|
||||
[content null]
|
||||
[docs null]
|
||||
|
|
@ -146,7 +146,7 @@
|
|||
(if val? value-color #f)
|
||||
(list
|
||||
(make-element (if val? value-color paren-color) '(". "))
|
||||
(typeset a #f "" "" (not val?))
|
||||
(typeset a #f "" "" "" (not val?))
|
||||
(make-element (if val? value-color paren-color) '(" .")))
|
||||
(+ (syntax-span a) 4)))
|
||||
(list (syntax-source a)
|
||||
|
|
@ -389,6 +389,7 @@
|
|||
(set! dest-col 0)
|
||||
(hash-table-put! next-col-map init-col dest-col)
|
||||
((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0) c)
|
||||
(out suffix #f)
|
||||
(unless (null? content)
|
||||
(finish-line!))
|
||||
(if multi-line?
|
||||
|
|
@ -396,16 +397,16 @@
|
|||
(make-sized-element #f (reverse content) dest-col))))
|
||||
|
||||
(define (to-element c)
|
||||
(typeset c #f "" "" #t))
|
||||
(typeset c #f "" "" "" #t))
|
||||
|
||||
(define (to-element/no-color c)
|
||||
(typeset c #f "" "" #f))
|
||||
(typeset c #f "" "" "" #f))
|
||||
|
||||
(define (to-paragraph c)
|
||||
(typeset c #t "" "" #t))
|
||||
(typeset c #t "" "" "" #t))
|
||||
|
||||
(define ((to-paragraph/prefix pfx1 pfx) c)
|
||||
(typeset c #t pfx1 pfx #t))
|
||||
(define ((to-paragraph/prefix pfx1 pfx sfx) c)
|
||||
(typeset c #t pfx1 pfx sfx #t))
|
||||
|
||||
(define-syntax (define-code stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user