suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

start on regexp functions; further formatting improvements for defproc

Browse Source 
svn: r6745

original commit: bf717526b0d76546793db9a52863547fbb030706
This commit is contained in:
Matthew Flatt 2007-06-27 00:17:04 +00:00
parent 4939c9cff0
commit c097769365
3 changed files with 158 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

174
collects/scribble/manual.ss
View File

@ -393,20 +393,21 @@
[(eq? v '...) [(eq? v '...)
dots0] dots0]
[else v]))] [else v]))]
[prototype-size (lambda (s) [prototype-size (lambda (s first-combine next-combine)
(let loop ([s s]) (let loop ([s s][combine first-combine])
(if (null? s) (if (null? s)
1 0
(+ 1 (loop (cdr s)) (combine
(cond (loop (cdr s) next-combine)
[(symbol? (car s)) (string-length (symbol->string (car s)))] (cond
[(pair? (car s)) [(symbol? (car s)) (string-length (symbol->string (car s)))]
(if (keyword? (caar s)) [(pair? (car s))
(+ (string-length (keyword->string (caar s))) (if (keyword? (caar s))
3 (+ (string-length (keyword->string (caar s)))
(string-length (symbol->string (cadar s)))) 3
(string-length (symbol->string (caar s))))] (string-length (symbol->string (cadar s))))
[else 0])))))]) (string-length (symbol->string (caar s))))]
[else 0])))))])
(parameterize ([current-variable-list (parameterize ([current-variable-list
(map (lambda (i) (map (lambda (i)
(and (pair? i) (and (pair? i)
@ -422,34 +423,41 @@
append append
(map (map
(lambda (stx-id prototype arg-contracts result-contract first?) (lambda (stx-id prototype arg-contracts result-contract first?)
(append (let*-values ([(required optional more-required)
(list (let loop ([a (cdr prototype)][r-accum null])
(list (make-flow (if (or (null? a)
(let-values ([(required optional more-required) (and (has-optional? (car a))))
(let loop ([a (cdr prototype)][r-accum null]) (let ([req (reverse r-accum)])
(if (or (null? a) (let loop ([a a][o-accum null])
(and (has-optional? (car a)))) (if (or (null? a)
(let ([req (reverse r-accum)]) (not (has-optional? (car a))))
(let loop ([a a][o-accum null]) (values req (reverse o-accum) a)
(if (or (null? a) (loop (cdr a) (cons (car a) o-accum)))))
(not (has-optional? (car a)))) (loop (cdr a) (cons (car a) r-accum))))]
(values req (reverse o-accum) a) [(tagged) (if first?
(loop (cdr a) (cons (car a) o-accum))))) (make-target-element
(loop (cdr a) (cons (car a) r-accum))))] #f
[(tagged) (if first? (list (to-element (make-just-context (car prototype)
(make-target-element stx-id)))
#f (register-scheme-definition stx-id))
(list (to-element (make-just-context (car prototype) (to-element (make-just-context (car prototype)
stx-id))) stx-id)))]
(register-scheme-definition stx-id)) [(flat-size) (prototype-size prototype + +)]
(to-element (make-just-context (car prototype) [(short?) (or (flat-size . < . 40)
stx-id)))] ((length prototype) . < . 3))]
[(short?) (or ((prototype-size prototype) . < . 40) [(res) (result-contract)]
((length prototype) . < . 3))] [(result-next-line?) ((+ (if short?
[(end) (list (to-flow spacer) flat-size
(to-flow 'rarr) (prototype-size prototype + max))
(to-flow spacer) (flow-element-width res))
(make-flow (list (result-contract))))]) . >= . 50)]
[(end) (list (to-flow spacer)
(to-flow 'rarr)
(to-flow spacer)
(make-flow (list res)))])
(append
(list
(list (make-flow
(if short? (if short?
(make-table-if-necessary (make-table-if-necessary
"prototype" "prototype"
@ -468,12 +476,16 @@
'paren-shape 'paren-shape
#\?)))) #\?))))
(map arg->elem more-required)))) (map arg->elem more-required))))
end))) (if result-next-line?
null
end))))
(let ([not-end (let ([not-end
(list (to-flow spacer) (if result-next-line?
(to-flow spacer) (list (to-flow spacer))
(to-flow spacer) (list (to-flow spacer)
(to-flow spacer))]) (to-flow spacer)
(to-flow spacer)
(to-flow spacer)))])
(list (list
(make-table (make-table
"prototype" "prototype"
@ -513,40 +525,46 @@
#f #f
(list a "]" (schemeparenfont ")"))))] (list a "]" (schemeparenfont ")"))))]
[else a]))) [else a])))
(if (null? (cdr args)) (if (and (null? (cdr args))
(not result-next-line?))
end end
not-end)) not-end))
(loop (cdr args) (sub1 req)))))))))))))) (loop (cdr args) (sub1 req)))))))))))))
(apply append (if result-next-line?
(map (lambda (v arg-contract) (list (list (make-flow (make-table-if-necessary
(cond "prototype"
[(pair? v) (list end)))))
(list null)
(list (apply append
(make-flow (map (lambda (v arg-contract)
(make-table-if-necessary (cond
"argcontract" [(pair? v)
(list (list
(let ([v (if (keyword? (car v)) (list
(cdr v) (make-flow
v)]) (make-table-if-necessary
(append "argcontract"
(list (list
(to-flow (hspace 2)) (let ([v (if (keyword? (car v))
(to-flow (arg->elem v)) (cdr v)
(to-flow spacer) v)])
(to-flow ":") (append
(to-flow spacer) (list
(make-flow (list (arg-contract)))) (to-flow (hspace 2))
(if (has-optional? v) (to-flow (arg->elem v))
(list (to-flow spacer) (to-flow spacer)
(to-flow "=") (to-flow ":")
(to-flow spacer) (to-flow spacer)
(to-flow (to-element (caddr v)))) (make-flow (list (arg-contract))))
null))))))))] (if (has-optional? v)
[else null])) (list (to-flow spacer)
(cdr prototype) (to-flow "=")
arg-contracts)))) (to-flow spacer)
(to-flow (to-element (caddr v))))
null))))))))]
[else null]))
(cdr prototype)
arg-contracts)))))
stx-ids stx-ids
prototypes prototypes
arg-contractss arg-contractss

3
collects/scribble/scheme.ss
View File

@ -372,7 +372,8 @@
(make-link-element "schemesyntaxlink" (list s) stag)] (make-link-element "schemesyntaxlink" (list s) stag)]
[vd [vd
(make-link-element "schemevaluelink" (list s) vtag)] (make-link-element "schemevaluelink" (list s) vtag)]
[else s]))))) [else s]))))
(lambda () s))
(literalize-spaces s)) (literalize-spaces s))
(cond (cond
[(positive? quote-depth) value-color] [(positive? quote-depth) value-color]

68
collects/scribble/struct.ss
View File

@ -95,28 +95,33 @@
delayed-element-ref delayed-element-ref
delayed-element-set!) delayed-element-set!)
(make-struct-type 'delayed-element #f (make-struct-type 'delayed-element #f
1 1 #f 2 1 #f
(list (cons prop:serializable (list (cons prop:serializable
(make-serialize-info (make-serialize-info
(lambda (d) (lambda (d)
(unless (delayed-element-ref d 1) (unless (delayed-element-ref d 2)
(error 'serialize-delayed-element (error 'serialize-delayed-element
"cannot serialize a delayed element that was not resolved: ~e" "cannot serialize a delayed element that was not resolved: ~e"
d)) d))
(vector (delayed-element-ref d 1))) (vector (delayed-element-ref d 2)))
#'deserialize-delayed-element #'deserialize-delayed-element
#f #f
(or (current-load-relative-directory) (current-directory))))))) (or (current-load-relative-directory) (current-directory)))))))
(define-syntax delayed-element (list-immutable #'struct:delayed-element (define-syntax delayed-element (list-immutable #'struct:delayed-element
#'make-delayed-element #'make-delayed-element
#'delayed-element? #'delayed-element?
(list-immutable #'delayed-element-render) (list-immutable #'delayed-element-sizer
(list-immutable #'set-delayed-element-render!) #'delayed-element-render)
(list-immutable #'set-delayed-element-sizer!
#'set-delayed-element-render!)
#t)) #t))
(define delayed-element-render (make-struct-field-accessor delayed-element-ref 0)) (define delayed-element-render (make-struct-field-accessor delayed-element-ref 0))
(define delayed-element-sizer (make-struct-field-accessor delayed-element-ref 1))
(define set-delayed-element-render! (make-struct-field-mutator delayed-element-set! 0)) (define set-delayed-element-render! (make-struct-field-mutator delayed-element-set! 0))
(define set-delayed-element-sizer! (make-struct-field-mutator delayed-element-set! 1))
(provide/contract (provide/contract
(struct delayed-element ([render (any/c part? any/c . -> . list?)]))) (struct delayed-element ([render (any/c part? any/c . -> . list?)]
[sizer (-> any)])))
(provide deserialize-delayed-element) (provide deserialize-delayed-element)
(define deserialize-delayed-element (define deserialize-delayed-element
@ -124,9 +129,9 @@
(provide force-delayed-element) (provide force-delayed-element)
(define (force-delayed-element d renderer sec ht) (define (force-delayed-element d renderer sec ht)
(or (delayed-element-ref d 1) (or (delayed-element-ref d 2)
(let ([v ((delayed-element-ref d 0) renderer sec ht)]) (let ([v ((delayed-element-ref d 0) renderer sec ht)])
(delayed-element-set! d 1 v) (delayed-element-set! d 2 v)
v))) v)))
;; ---------------------------------------- ;; ----------------------------------------
@ -163,5 +168,52 @@
renderer sec ht)] renderer sec ht)]
[else (element->string c)])])) [else (element->string c)])]))
;; ----------------------------------------
(provide flow-element-width
element-width)
(define (element-width s)
(cond
[(string? s) (string-length s)]
[(element? s) (apply + (map element-width (element-content s)))]
[(delayed-element? s) (element-width ((delayed-element-sizer s)))]
[else 1]))
(define (paragraph-width s)
(apply + (map element-width (paragraph-content s))))
(define (flow-width f)
(apply max 0 (map flow-element-width (flow-paragraphs f))))
(define (flow-element-width p)
(cond
[(paragraph? p) (paragraph-width p)]
[(table? p) (table-width p)]
[(itemization? p) (itemization-width p)]
[(blockquote? p) (blockquote-width p)]
[(delayed-flow-element? p) 1]))
(define (table-width p)
(let ([flowss (table-flowss p)])
(if (null? flowss)
0
(let loop ([flowss flowss])
(if (null? (car flowss))
0
(+ (apply max
0
(map flow-width
(map car flowss)))
(loop (map cdr flowss))))))))
(define (itemization-width p)
(apply max 0 (map flow-width (itemization-flows p))))
(define (blockquote-width p)
(+ 4 (apply max 0 (map paragraph-width (blockquote-paragraphs p)))))
;; ----------------------------------------
) )