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

less surprising sort of index entries

Browse Source 
svn: r10064

original commit: 331628d8b433a6d6907e95599f4b042d4b2aedb9
This commit is contained in:
Eli Barzilay 2008-05-31 06:10:06 +00:00
parent b8d52932ef
commit 776e71fbb6
1 changed files with 115 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

185
collects/scribble/basic.ss
View File

@ -4,6 +4,8 @@
(require "decode.ss" (require "decode.ss"
"struct.ss" "struct.ss"
"config.ss" "config.ss"
"manual-struct.ss"
"decode-struct.ss"
scheme/list scheme/list
scheme/class scheme/class
setup/main-collects setup/main-collects
@ -161,7 +163,8 @@
;; ---------------------------------------- ;; ----------------------------------------
(provide section-index index index* as-index index-section index-blocks) (provide section-index index index* as-index index-section
get-index-entries index-block)
(define (section-index . elems) (define (section-index . elems)
(make-part-index-decl (map element->string elems) elems)) (make-part-index-decl (map element->string elems) elems))
@ -198,23 +201,75 @@
(list title) (list title)
'index 'index
null null
(make-flow (index-blocks)) (make-flow (list (index-block)))
null)) null))
(define (index-blocks) ;; returns an ordered list of (list tag (text ...) (element ...) index-desc)
(define (commas l) (define (get-index-entries sec ri)
(if (or (null? l) (null? (cdr l))) (define (compare-lists xs ys <?)
l (let loop ([xs xs] [ys ys])
(cdr (append-map (lambda (i) (list ", " i)) l)))) (cond [(and (null? xs) (null? ys)) '=]
(define (cadr-string-lists<? a b) [(null? xs) '<]
(let loop ([a (cadr a)] [b (cadr b)]) [(null? ys) '>]
(cond [(null? b) #f] [(<? (car xs) (car ys)) '<]
[(null? a) #t] [(<? (car ys) (car xs)) '>]
[(string-ci=? (car a) (car b)) [else (loop (cdr ys) (cdr xs))])))
(or (loop (cdr a) (cdr b)) ;; string-ci<? as a major key, and string<? next, so "Foo" precedes "foo"
;; Try string<? so "Foo" still precedes "foo" ;; (define (string*<? s1 s2)
(string<? (car a) (car b)))] ;; (or (string-ci<? s1 s2)
[else (string-ci<? (car a) (car b))]))) ;; (and (not (string-ci<? s2 s1)) (string<? s1 s2))))
(define (get-desc entry)
(let ([desc (cadddr entry)])
(cond [(exported-index-desc? desc)
(cons 'libs (map symbol->string
(exported-index-desc-from-libs desc)))]
[(module-path-index-desc? desc) '(mod)]
[(part-index-desc? desc) '(part)]
[(delayed-index-desc? desc) '(delayed)]
[else '(#f)])))
;; parts first, then modules, then bindings, delayed means it's not
;; the last round, and #f means no desc
(define desc-order '(part mod libs delayed #f))
(define (compare-desc e1 e2)
(let* ([d1 (get-desc e1)] [d2 (get-desc e2)]
[t1 (car d1)] [t2 (car d2)])
(cond [(memq t2 (cdr (memq t1 desc-order))) '<]
[(memq t1 (cdr (memq t2 desc-order))) '>]
[else (case t1 ; equal to t2
[(part) '=] ; will just compare tags
[(mod) '=] ; the text fields are the names of the modules
[(libs) (compare-lists (cdr d1) (cdr d2) string<?)]
[(delayed) '>] ; dosn't matter, will run again
[(#f) '=])])))
(define (entry<? e1 e2)
(let ([text1 (cadr e1)] [text2 (cadr e2)])
(case (compare-lists text1 text2 string-ci<?)
[(<) #t] [(>) #f]
[else (case (compare-desc e1 e2)
[(<) #t] [(>) #f]
[else (case (compare-lists text1 text2 string<?)
[(<) #t] [(>) #f]
[else
;; (error 'get-index-entries
;; ;; when this happens, revise this code so
;; ;; ordering will always be deterministic
;; "internal error -- unordered entries: ~e ~e"
;; e1 e2)
;; Instead, just compare the tags
(string<? (format "~a" (car e1))
(format "~a" (car e2)))])])])))
(define l null)
(hash-for-each
(let ([parent (collected-info-parent (part-collected-info sec ri))])
(if parent
(collected-info-info (part-collected-info parent ri))
(collect-info-ext-ht (resolve-info-ci ri))))
(lambda (k v)
(when (and (pair? k) (eq? 'index-entry (car k)))
(set! l (cons (cons (cadr k) v) l)))))
(sort l entry<?))
(define (index-block)
(define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) (define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
(define (rows . rows) (define (rows . rows)
(make-table 'index (map (lambda (row) (make-table 'index (map (lambda (row)
@ -222,61 +277,51 @@
rows))) rows)))
(define contents (define contents
(lambda (renderer sec ri) (lambda (renderer sec ri)
(define l null) (define l (get-index-entries sec ri))
(define line-break (if (send renderer index-manual-newlines?) (define manual-newlines? (send renderer index-manual-newlines?))
(make-element 'newline '("\n"))
""))
(define alpha-starts (make-hasheq)) (define alpha-starts (make-hasheq))
(hash-for-each (define alpha-row
(let ([parent (collected-info-parent (part-collected-info sec ri))]) (let loop ([i l] [alpha alpha])
(if parent (define (add-letter let l)
(collected-info-info (part-collected-info parent ri)) (list* (make-element "nonavigation" (list (string let))) " " l))
(collect-info-ext-ht (resolve-info-ci ri)))) (cond [(null? alpha) null]
(lambda (k v) [(null? i) (add-letter (car alpha) (loop i (cdr alpha)))]
(when (and (pair? k) (eq? 'index-entry (car k))) [else
(set! l (cons (cons (cadr k) v) l))))) (let* ([strs (cadr (car i))]
(set! l (sort l cadr-string-lists<?)) [letter (if (or (null? strs) (string=? "" (car strs)))
(apply #f
rows (char-upcase (string-ref (car strs) 0)))])
(let loop ([i l] [alpha alpha]) (cond [(not letter) (loop (cdr i) alpha)]
(define (add-letter let l) [(char-ci>? letter (car alpha))
(list* (make-element "nonavigation" (list (string let))) " " l)) (add-letter (car alpha) (loop i (cdr alpha)))]
(cond [(null? alpha) null] [(char-ci=? letter (car alpha))
[(null? i) (add-letter (car alpha) (loop i (cdr alpha)))] (hash-set! alpha-starts (car i) letter)
[else (list* (make-element
(let* ([strs (cadr (car i))] (make-target-url (format "#alpha:~a" letter)
[letter (if (or (null? strs) (string=? "" (car strs))) #f)
#f (list (string (car alpha))))
(char-upcase (string-ref (car strs) 0)))]) " "
(cond [(not letter) (loop (cdr i) alpha)] (loop (cdr i) (cdr alpha)))]
[(char-ci>? letter (car alpha)) [else (loop (cdr i) alpha)]))])))
(add-letter (car alpha) (loop i (cdr alpha)))] (define body
[(char-ci=? letter (car alpha)) (let ([br (if manual-newlines? (make-element 'newline '("\n")) "")])
(hash-set! alpha-starts (car i) letter) (map (lambda (i)
(list* (make-element (let ([e (make-link-element
(make-target-url (format "#alpha:~a" letter) #f) "indexlink"
(list (string (car alpha)))) `(,@(add-between (caddr i) ", ") ,br)
" " (car i))])
(loop (cdr i) (cdr alpha)))] (cond [(hash-ref alpha-starts i #f)
[else (loop (cdr i) alpha)]))])) => (lambda (let)
(list 'nbsp) (make-element
((if (send renderer index-manual-newlines?) (make-url-anchor
list (format "alpha:~a" (char-upcase let)))
(lambda (v) (list e)))]
(map list v))) [else e])))
(map (lambda (i) l)))
(define e (if manual-newlines?
(make-link-element "indexlink" (rows alpha-row '(nbsp) body)
`(,@(commas (caddr i)) ,line-break) (apply rows alpha-row '(nbsp) (map list body)))))
(car i))) (make-delayed-block contents))
(cond [(hash-ref alpha-starts i #f)
=> (lambda (let)
(make-element (make-url-anchor
(format "alpha:~a" (char-upcase let)))
(list e)))]
[else e]))
l)))))
(list (make-delayed-block contents)))
;; ---------------------------------------- ;; ----------------------------------------