suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

experiment with a more contract-like form for docs

Browse Source 
svn: r6569

original commit: 4f3afd9c75b9d4f8ee115884b94a583881e7171a
This commit is contained in:
Matthew Flatt 2007-06-11 01:02:41 +00:00
parent 0ae283cd18
commit 893d7d9098
3 changed files with 152 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/scribble/html-render.ss
View File

@ -136,7 +136,8 @@
(define/override (render-element e part ht) (define/override (render-element e part ht)
(cond (cond
[(target-element? e) [(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) [(and (link-element? e)
(not (current-no-links))) (not (current-no-links)))
(parameterize ([current-no-links #t]) (parameterize ([current-no-links #t])

250
collects/scribble/manual.ss
View File

@ -17,9 +17,11 @@
(define-code schemeblock0 to-paragraph) (define-code schemeblock0 to-paragraph)
(define-code schemeblock (to-paragraph/prefix (hspace 2) (define-code schemeblock (to-paragraph/prefix (hspace 2)
(hspace 2))) (hspace 2)
""))
(define-code SCHEMEBLOCK (to-paragraph/prefix (hspace 2) (define-code SCHEMEBLOCK (to-paragraph/prefix (hspace 2)
(hspace 2)) (hspace 2)
"")
UNSYNTAX) UNSYNTAX)
(define-code SCHEMEBLOCK0 to-paragraph UNSYNTAX) (define-code SCHEMEBLOCK0 to-paragraph UNSYNTAX)
(define-code schemeinput (to-paragraph/prefix (make-element (define-code schemeinput (to-paragraph/prefix (make-element
@ -27,7 +29,8 @@
(list (list
(hspace 2) (hspace 2)
(make-element 'tt (list "> " )))) (make-element 'tt (list "> " ))))
(hspace 4))) (hspace 4)
""))
(define-syntax (schememod stx) (define-syntax (schememod stx)
(syntax-case stx () (syntax-case stx ()
@ -161,45 +164,75 @@
(define dots1 (define dots1
(make-element #f (list "..." (superscript "+")))) (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) (define-syntax (arg-contract stx)
(syntax-case stx (... ...+) (syntax-case stx (... ...+)
[(_ [id contract]) [(_ [id contract] typeset)
(identifier? #'id) (identifier? #'id)
#'(schemeblock0 contract)] #'(typeset contract)]
[(_ [id contract val]) [(_ [id contract val] typeset)
(identifier? #'id) (identifier? #'id)
#'(schemeblock0 contract)] #'(typeset contract)]
[(_ [kw id contract]) [(_ [kw id contract] typeset)
(and (keyword? (syntax-e #'kw)) (and (keyword? (syntax-e #'kw))
(identifier? #'id)) (identifier? #'id))
#'(schemeblock0 contract)] #'(typeset contract)]
[(_ [kw id contract val]) [(_ [kw id contract val] typeset)
(and (keyword? (syntax-e #'kw)) (and (keyword? (syntax-e #'kw))
(identifier? #'id)) (identifier? #'id))
#'(schemeblock0 contract)] #'(typeset contract)]
[(_ (... ...)) [(_ (... ...) typeset)
#'#f] #'#f]
[(_ (... ...+)) [(_ (... ...+) typeset)
#'#f] #'#f]
[(_ arg) [(_ arg typeset)
(raise-syntax-error (raise-syntax-error
'defproc 'defproc
"bad argument form" "bad argument form"
#'arg)])) #'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 (define-syntax defproc
(syntax-rules () (syntax-rules ()
[(_ (id arg ...) result desc ...) [(_ (id arg ...) result desc ...)
(*defproc '[(id arg ...)] (*defproc '[(id arg ...)]
(list (list (lambda () (arg-contract arg)) ...)) (list (arg-contracts arg ...))
(list (lambda () (schemeblock0 result))) (list (lambda () (schemeblock0 result)))
(lambda () (list desc ...)))])) (lambda () (list desc ...)))]))
(define-syntax defproc* (define-syntax defproc*
(syntax-rules () (syntax-rules ()
[(_ [[(id arg ...) result] ...] desc ...) [(_ [[(id arg ...) result] ...] desc ...)
(*defproc '[(id arg ...) ...] (*defproc '[(id arg ...) ...]
(list (list (lambda () (arg-contract arg)) ...) ...) (list (arg-contracts arg ...) ...)
(list (lambda () (schemeblock0 result)) ...) (list (lambda () (schemeblock0 result)) ...)
(lambda () (list desc ...)))])) (lambda () (list desc ...)))]))
(define-syntax defstruct (define-syntax defstruct
@ -282,20 +315,7 @@
3 3
2))))] 2))))]
[to-flow (lambda (e) [to-flow (lambda (e)
(make-flow (list (make-paragraph (list 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]))])
(parameterize ([current-variable-list (parameterize ([current-variable-list
(map (lambda (i) (map (lambda (i)
(and (pair? i) (and (pair? i)
@ -307,86 +327,97 @@
(cons (cons
(make-table (make-table
'boxed 'boxed
(apply (apply
append append
(map (map
(lambda (prototype arg-contracts result-contract first?) (lambda (prototype arg-contracts result-contract first?)
(append (let ([name (if first?
(list (make-target-element
(list (make-flow #f
(list (list (to-element (car prototype)))
(make-table (register-scheme-definition (car prototype)))
'((valignment top top top top top)) (to-element (car prototype)))])
(list (list
(list (list
(to-flow (make-flow
(let-values ([(required optional more-required) (list
(let loop ([a (cdr prototype)][r-accum null]) (if (null? (cdr prototype))
(if (or (null? a) (make-table
(and (has-optional? (car a)))) #f
(let ([req (reverse r-accum)]) (list (list
(let loop ([a a][o-accum null]) (make-flow
(if (or (null? a) (list
(not (has-optional? (car a)))) (make-paragraph
(values req (reverse o-accum) a) (list (schemeparenfont "(")
(loop (cdr a) (cons (car a) o-accum))))) name
(loop (cdr a) (cons (car a) r-accum))))]) (schemeparenfont ")"))))))))
(to-element (append (make-table
(list (if first? #f
(make-target-element (let loop ([args (cdr prototype)]
#f [arg-contracts arg-contracts]
(list (to-element (car prototype))) [first? #t])
(register-scheme-definition (car prototype))) (let* ([a (car args)]
(to-element (car prototype)))) [v (if (keyword? (car a))
(map arg->elem required) (cdr a)
(if (null? optional) a)]
null [dots (and (pair? (cdr args))
(list (not (pair? (cadr args)))
(to-element (cadr args))])
(syntax-property (cons
(syntax-ize (map arg->elem optional) 0) (list (if first?
'paren-shape (make-flow
#\?)))) (list
(map arg->elem more-required))))) (make-paragraph
(to-flow spacer) (list
(to-flow 'rarr) (schemeparenfont "(")
(to-flow spacer) name
(make-flow (list (result-contract)))))))))) spacer))))
(apply append (to-flow spacer))
(map (lambda (v arg-contract) (make-flow
(cond (list
[(pair? v) (make-table
(list '((valignment baseline baseline baseline))
(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
(list (list
(to-flow (hspace 2)) (make-flow
(to-flow (arg->elem v)) (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 spacer)
(to-flow ":") (make-flow
(to-flow spacer) ;; Note: arg-contract includes closing paren for arg,
(make-flow (list (arg-contract)))) ;; as well as dots or closing paren for arg sequence
(if (has-optional? v) (list ((car arg-contracts))))))))))
(list (to-flow spacer) (let ([next (if dots
(to-flow "=") (cddr args)
(to-flow spacer) (cdr args))])
(to-flow (to-element (caddr v)))) (if (null? next)
null)))))))))] null
[else null])) (loop next
(cdr prototype) ((if dots cddr cdr) arg-contracts)
arg-contracts)))) #f)))))))))))
(list
(make-flow
(list
(make-table
#f
(list (list (to-flow spacer)
(to-flow spacer)
(make-flow (list (result-contract))))))))))))
prototypes prototypes
arg-contractss arg-contractss
result-contracts result-contracts
@ -465,8 +496,11 @@
(list (make-target-element (list (make-target-element
#f #f
(list (to-element name)) (list (to-element name))
(register-scheme-definition name)) (register-scheme-definition name)))))))
spacer ":" spacer (list (make-flow
(list
(make-paragraph
(list spacer spacer
(to-element result-contract)))))))) (to-element result-contract))))))))
(content-thunk)))) (content-thunk))))

15
collects/scribble/scheme.ss
View File

@ -44,7 +44,7 @@
(define-struct (sized-element element) (length)) (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)] (let* ([c (syntax-ize c 0)]
[content null] [content null]
[docs null] [docs null]
@ -146,7 +146,7 @@
(if val? value-color #f) (if val? value-color #f)
(list (list
(make-element (if val? value-color paren-color) '(". ")) (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) '(" ."))) (make-element (if val? value-color paren-color) '(" .")))
(+ (syntax-span a) 4))) (+ (syntax-span a) 4)))
(list (syntax-source a) (list (syntax-source a)
@ -389,6 +389,7 @@
(set! dest-col 0) (set! dest-col 0)
(hash-table-put! next-col-map init-col dest-col) (hash-table-put! next-col-map init-col dest-col)
((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0) c) ((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0) c)
(out suffix #f)
(unless (null? content) (unless (null? content)
(finish-line!)) (finish-line!))
(if multi-line? (if multi-line?
@ -396,16 +397,16 @@
(make-sized-element #f (reverse content) dest-col)))) (make-sized-element #f (reverse content) dest-col))))
(define (to-element c) (define (to-element c)
(typeset c #f "" "" #t)) (typeset c #f "" "" "" #t))
(define (to-element/no-color c) (define (to-element/no-color c)
(typeset c #f "" "" #f)) (typeset c #f "" "" "" #f))
(define (to-paragraph c) (define (to-paragraph c)
(typeset c #t "" "" #t)) (typeset c #t "" "" "" #t))
(define ((to-paragraph/prefix pfx1 pfx) c) (define ((to-paragraph/prefix pfx1 pfx sfx) c)
(typeset c #t pfx1 pfx #t)) (typeset c #t pfx1 pfx sfx #t))
(define-syntax (define-code stx) (define-syntax (define-code stx)
(syntax-case stx () (syntax-case stx ()