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

doc and test repairs

Browse Source 
svn: r8597

original commit: 1959c567431344b468d47fa873e093b5ab0787c4
This commit is contained in:
Matthew Flatt 2008-02-09 13:01:39 +00:00
parent 0e156fe8db
commit a05fd5eb87
3 changed files with 72 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/scribble/basic.ss
View File

@ -111,8 +111,15 @@
tt span-class tt span-class
subscript superscript) subscript superscript)
(define hspace-cache (make-vector 100 #f))
(define (hspace n) (define (hspace n)
(make-element 'hspace (list (make-string n #\space)))) (if (n . < . (vector-length hspace-cache))
(or (vector-ref hspace-cache n)
(let ([h (make-element 'hspace (list (make-string n #\space)))])
(vector-set! hspace-cache n h)
h))
(make-element 'hspace (list (make-string n #\space)))))
(define (elem . str) (define (elem . str)
(make-element #f (decode-content str))) (make-element #f (decode-content str)))

2
collects/scribble/run.ss
View File

@ -58,7 +58,7 @@
(define (build-docs-files files) (define (build-docs-files files)
(build-docs (map (lambda (file) (build-docs (map (lambda (file)
(dynamic-require file 'doc)) (dynamic-require `(file ,file) 'doc))
files) files)
files)) files))

83
collects/scribble/scheme.ss
View File

@ -54,11 +54,57 @@
(make-spaces #f (make-spaces #f
(list (list
(literalize-spaces (substring i 0 (caar m))) (literalize-spaces (substring i 0 (caar m)))
(make-element 'hspace (list (make-string cnt #\space))) (hspace cnt)
(literalize-spaces (substring i (cdar m)))) (literalize-spaces (substring i (cdar m))))
cnt)) cnt))
i))) i)))
(define line-breakable-space (make-element 'tt (list " ")))
(define id-element-cache #f #;(make-hash-table 'equal))
(define element-cache #f #;(make-hash-table 'equal))
(define (make-id-element c s)
(let* ([key (and id-element-cache
(let ([b (identifier-label-binding c)])
(list (syntax-e c)
(module-path-index-resolve (caddr b))
(cadddr b)
(list-ref b 5))))])
(or (and key
(hash-table-get id-element-cache key #f))
(let ([e (make-delayed-element
(lambda (renderer sec ri)
(let* ([tag (find-scheme-tag sec ri c 'for-label)])
(if tag
(list
(case (car tag)
[(form)
(make-link-element "schemesyntaxlink" (list s) tag)]
[else
(make-link-element "schemevaluelink" (list s) tag)]))
(list
(make-element "badlink"
(list (make-element "schemevaluelink" (list s))))))))
(lambda () s)
(lambda () s))])
(when key
(hash-table-put! id-element-cache key e))
e))))
(define (make-element/cache style content)
(if (and element-cache
(pair? content)
(string? (car content))
(null? (cdr content)))
(let ([key (cons style content)])
(or (hash-table-get element-cache key #f)
(let ([e (make-element style content)])
(hash-table-put! element-cache key e)
e)))
(make-element style content)))
(define (typeset-atom c out color? quote-depth) (define (typeset-atom c out color? quote-depth)
(let*-values ([(is-var?) (and (identifier? c) (let*-values ([(is-var?) (and (identifier? c)
(memq (syntax-e c) (current-variable-list)))] (memq (syntax-e c) (current-variable-list)))]
@ -81,21 +127,7 @@
(quote-depth . <= . 0) (quote-depth . <= . 0)
(not (or it? is-var?))) (not (or it? is-var?)))
(if (pair? (identifier-label-binding c)) (if (pair? (identifier-label-binding c))
(make-delayed-element (make-id-element c s)
(lambda (renderer sec ri)
(let* ([tag (find-scheme-tag sec ri c 'for-label)])
(if tag
(list
(case (car tag)
[(form)
(make-link-element "schemesyntaxlink" (list s) tag)]
[else
(make-link-element "schemevaluelink" (list s) tag)]))
(list
(make-element "badlink"
(list (make-element "schemevaluelink" (list s))))))))
(lambda () s)
(lambda () s))
s) s)
(literalize-spaces s)) (literalize-spaces s))
(cond (cond
@ -183,7 +215,7 @@
(make-element "highlighted" (list c))) (make-element "highlighted" (list c)))
values) values)
(if (and color? cls) (if (and color? cls)
(make-element cls (list v)) (make-element/cache cls (list v))
v)) v))
content)) content))
(set! dest-col (+ dest-col len))]))])) (set! dest-col (+ dest-col len))]))]))
@ -208,8 +240,8 @@
(when (positive? amt) (when (positive? amt)
(let ([old-dest-col dest-col]) (let ([old-dest-col dest-col])
(out (if (and (= 1 amt) (not multi-line?)) (out (if (and (= 1 amt) (not multi-line?))
(make-element 'tt (list " ")) ; allows a line break to replace the space line-breakable-space ; allows a line break to replace the space
(make-element 'hspace (list (make-string amt #\space)))) (hspace amt))
#f) #f)
(set! dest-col (+ old-dest-col amt)))))) (set! dest-col (+ old-dest-col amt))))))
(set! src-col c) (set! src-col c)
@ -240,9 +272,9 @@
(make-sized-element (make-sized-element
(if val? value-color #f) (if val? value-color #f)
(list (list
(make-element (if val? value-color paren-color) '(". ")) (make-element/cache (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/cache (if val? value-color paren-color) '(" .")))
(+ (syntax-span a) 4))) (+ (syntax-span a) 4)))
(list (syntax-source a) (list (syntax-source a)
(syntax-line a) (syntax-line a)
@ -480,11 +512,16 @@
(graph-reference? s)) (graph-reference? s))
(gen-typeset c multi-line? prefix1 prefix suffix color?) (gen-typeset c multi-line? prefix1 prefix suffix color?)
(typeset-atom c (typeset-atom c
(letrec ([mk
(case-lambda (case-lambda
[(elem color) [(elem color)
(make-sized-element (and color? color) (list elem) (or (syntax-span c) 1))] (mk elem color (or (syntax-span c) 1))]
[(elem color len) [(elem color len)
(make-sized-element (and color? color) (list elem) len)]) (if (and (string? elem)
(= len (string-length elem)))
(make-element/cache (and color? color) (list elem))
(make-sized-element (and color? color) (list elem) len))])])
mk)
color? 0)))) color? 0))))
(define (to-element c) (define (to-element c)