commit 798155c4f9b70d0e07208c9fa0159df078a2f351
parent 2881ef290ddfef6b645eaabc997c9bd6fddaa641
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 9 Jan 2016 20:21:18 -0700
add `make-numberer` to generalize section numbering
Diffstat:
8 files changed, 285 insertions(+), 50 deletions(-)
diff --git a/scribble-doc/scribblings/scribble/core.scrbl b/scribble-doc/scribblings/scribble/core.scrbl
@@ -396,10 +396,19 @@ The recognized @tech{style properties} are as follows:
@racket['hidden] (for consistency in non-Latex output).}
@item{@racket['grouper] --- The part is numbered with a Roman
- numeral, and its subsections continue numbering as if they
- appeared in the preceeding part. In other words, the part acts
- like a ``part'' in a book where chapter numbering is continuous
- across parts.}
+ numeral, by default, and its subsections continue numbering as
+ if they appeared in the preceeding part. In other words, the
+ part acts like a ``part'' in a book where chapter numbering is
+ continuous across parts.}
+
+ @item{@tech{numberer} --- A @tech{numberer} created with
+ @racket[make-numberer] determines a representation of the
+ part's section number as an extension of it's patent's number.
+ A @tech{numberer} overrides the default representation, which
+ is a natural number or (in the case of an accompanying
+ @racket['grouper] property) a Roman numeral. If a
+ @racket['unnumbered] property is also present, a
+ @tech{numberer} property is ignored.}
@item{@racket['toc] --- Sub-parts of the part are rendered on separate
pages for multi-page HTML mode.}
@@ -1076,18 +1085,42 @@ If a @racket[render-element] instance is serialized (such as when
saving collected info), it is reduced to a @racket[element] instance.}
-@defstruct[collected-info ([number (listof (or/c #f exact-nonnegative-integer? string?))]
+@defstruct[collected-info ([number (listof part-number-item?)]
[parent (or/c #f part?)]
[info any/c])]{
Computed for each part by the @techlink{collect pass}.
The length of the @racket[number] list indicates the section's nesting
-depth. Numbers in @racket[number] correspond to the section's number,
-it's parent's number, etc. A non-empty string is used for a
-@racket['grouper] section. For an unnumbered section, @racket[#f] is
-used in place of all numbers and @racket[""] in place of all non-empty
-strings.}
+depth. Elements of @racket[number] correspond to the section's number,
+it's parent's number, and so on (that is, the section numbers are in
+reverse order):
+
+@itemlist[
+
+ @item{A number value corresponds to a normally numbered
+ section.}
+
+ @item{A non-empty string corresponds to a @racket['grouper] section,
+ which is shown as part of the combined section number only when
+ it's the first element.}
+
+ @item{A a list corresponds to a @tech{numberer}-generated section
+ string plus its separator string, where the separator is used
+ in a combined section number after the section string and
+ before a subsection's number (or, for some output modes, before
+ the title of the section).}
+
+ @item{For an unnumbered section, a @racket[#f] is used in place of
+ any number or lists element, while @racket[""] is used in place
+ of all non-empty strings.}
+
+]}
+
+@history[#:changed "6.4" @elem{Added @racket[(list/c string? string?)]
+ number items for
+ @tech{numberer}-generated section
+ numbers.}]}
@defstruct[target-url ([addr path-string?])]{
@@ -1313,6 +1346,61 @@ Returns the width in characters of the given @tech{content}.
Returns the width in characters of the given @tech{block}.}
+@defproc[(part-number-item? [v any/c]) boolean]{
+
+Return @racket[#t] if @racket[v] is @racket[#f], an exact non-negative
+integer, a string, or a list containing two strings. See @racket[part]
+for information on how different representations are used for numbering.
+
+@history[#:added "6.4"]}
+
+
+@deftogether[(
+@defproc[(numberer? [v any/c]) boolean?]
+@defproc[(make-numberer [step (any/c (listof part-number-item?)
+ . -> .
+ (values part-number-item? any/c))]
+ [initial-value any/c])
+ numberer?]
+@defproc[(numberer-step [n numberer?]
+ [parent-number (listof part-number-item?)]
+ [ci collect-info?]
+ [numberer-values hash?])
+ (values part-number-item? hash?)]
+)]{
+
+A @deftech{numberer} implements a representation of a section number
+that increment separately from the default numbering style and that
+can be rendered differently than as Arabic numerals.
+
+The @racket[numberer?] function returns @racket[#t] if @racket[v] is a
+@tech{numberer}, or @racket[#f] otherwise.
+
+The @racket[make-numberer] function creates a @tech{numberer}. The
+@racket[step] function computes both the current number's
+representation and increments the number, where the ``number'' can be
+an arbitrary value; the @racket[initial-value] argument determines the
+initial value of the ``number'', and the @racket[step] function
+receives the current value as its first argument and returns an
+incremented value as its second result. A numberer's ``number'' value
+starts fresh at each new nesting level. In addition to the numberer's
+current value, the @racket[step] function receives the parent
+section's numbering (so that its result can depend on the part's
+nesting depth).
+
+The @racket[numberer-step] function is normally used by a renderer. It
+applies a @tech{numberer}, given the parent section's number, a
+@racket[collect-info] value, and a hash table that accumulates
+@tech{numberer} values at a given nesting layer. The
+@racket[collect-info] argument is needed because a @tech{numberer}'s
+identity is based on a @racket[generated-tag]. The result of
+@racket[numberer-step] is the rendered form of the current section
+number plus an updated hash table with an incremented value for the
+@tech{numberer}.
+
+@history[#:added "6.4"]}
+
+
@defstruct[collect-info ([fp any/c] [ht any/c] [ext-ht any/c]
[ext-demand (tag? collect-info? . -> . any/c)]
[parts any/c]
diff --git a/scribble-lib/scribble/base-render.rkt b/scribble-lib/scribble/base-render.rkt
@@ -71,7 +71,7 @@
(define/public (index-manual-newlines?)
#f)
- (define/public (format-number number sep)
+ (define/public (format-number number sep [keep-separator? #f])
(if (or (null? number)
(andmap (lambda (x) (or (not x) (equal? x "")))
number)
@@ -81,13 +81,25 @@
(cons (let ([s (string-append
(apply
string-append
- (map (lambda (n) (if (number? n) (format "~a." n) ""))
+ (map (lambda (n)
+ (cond
+ [(number? n) (format "~a." n)]
+ [(or (not n) (string? n)) ""]
+ [(pair? n) (string-append (car n) (cadr n))]))
(reverse (cdr number))))
(if (and (car number)
(not (equal? "" (car number))))
- (format "~a." (car number))
+ (if (pair? (car number))
+ (if keep-separator?
+ (string-append (caar number)
+ (cadar number))
+ (caar number))
+ (format "~a." (car number)))
""))])
- (substring s 0 (sub1 (string-length s))))
+ (if (or keep-separator?
+ (pair? (car number)))
+ s
+ (substring s 0 (sub1 (string-length s)))))
sep)))
(define/public (number-depth number)
@@ -501,10 +513,10 @@
ci))
(define/public (start-collect ds fns ci)
- (map (lambda (d) (collect-part d #f ci null 1))
- ds))
+ (for-each (lambda (d) (collect-part d #f ci null 1 #hash()))
+ ds))
- (define/public (collect-part d parent ci number init-sub-number)
+ (define/public (collect-part d parent ci number init-sub-number init-sub-numberers)
(let ([p-ci (make-collect-info
(collect-info-fp ci)
(make-hash)
@@ -524,7 +536,7 @@
parent
(collect-info-ht p-ci)))
(define grouper? (and (pair? number) (part-style? d 'grouper)))
- (define next-sub-number
+ (define-values (next-sub-number next-sub-numberers)
(parameterize ([current-tag-prefixes
(extend-prefix d (fresh-tag-collect-context? d p-ci))])
(when (part-title-content d)
@@ -534,37 +546,54 @@
(collect-flow (part-blocks d) p-ci)
(let loop ([parts (part-parts d)]
[pos init-sub-number]
- [sub-pos 1])
+ [numberers init-sub-numberers]
+ [sub-pos 1]
+ [sub-numberers #hash()])
(if (null? parts)
- pos
+ (values pos numberers)
(let ([s (car parts)])
(define unnumbered? (part-style? s 'unnumbered))
(define hidden-number? (or unnumbered?
(part-style? s 'hidden-number)))
(define sub-grouper? (part-style? s 'grouper))
- (define next-sub-pos
+ (define numberer (and (not unnumbered?)
+ (for/or ([p (style-properties (part-style s))]
+ #:when (numberer? p))
+ p)))
+ (define-values (numberer-str next-numberers)
+ (if numberer
+ (numberer-step numberer number p-ci numberers)
+ (values #f numberers)))
+ (define-values (next-sub-pos next-sub-numberers)
(collect-part s d p-ci
(cons (if hidden-number?
(if sub-grouper?
""
#f)
- (if sub-grouper?
- (number->roman pos)
- pos))
+ (if numberer
+ numberer-str
+ (if sub-grouper?
+ (number->roman pos)
+ pos)))
(if hidden-number?
(for/list ([i (in-list number)])
(if (string? i)
i
#f))
number))
- sub-pos))
+ sub-pos
+ sub-numberers))
(loop (cdr parts)
- (if unnumbered?
+ (if (or unnumbered? numberer)
pos
(add1 pos))
+ next-numberers
(if sub-grouper?
next-sub-pos
- 1)))))))
+ 1)
+ (if sub-grouper?
+ next-sub-numberers
+ #hash())))))))
(let ([prefix (part-tag-prefix d)])
(for ([(k v) (collect-info-ht p-ci)])
(when (cadr k)
@@ -572,7 +601,7 @@
(convert-key prefix k)
k)
v))))
- next-sub-number))
+ (values next-sub-number next-sub-numberers)))
(define/private (convert-key prefix k)
(case (car k)
diff --git a/scribble-lib/scribble/core.rkt b/scribble-lib/scribble/core.rkt
@@ -160,6 +160,57 @@
(andmap (λ (l) (= l1 (length l)))
(cdr ls)))))
+;; ----------------------------------------
+
+(define-struct numberer (tag step-proc initial-value)
+ #:constructor-name numberer
+ #:property
+ prop:serializable
+ (make-serialize-info
+ (lambda (d)
+ (vector (numberer-tag d)
+ (numberer-initial-value d)))
+ #'deserialize-numberer
+ #f
+ (or (current-load-relative-directory) (current-directory))))
+
+(provide deserialize-numberer)
+(define deserialize-numberer
+ (make-deserialize-info (lambda (tag init-val)
+ (numberer tag #f))
+ (lambda (tag init-val)
+ (error "cannot allocate numberer for cycle"))))
+
+(define (make-numberer spec-proc initial-value)
+ (numberer (generated-tag) spec-proc initial-value))
+
+(define (numberer-step n parent-numbers ci ht)
+ (define tag (generate-tag `(numberer ,(numberer-tag n)) ci))
+ (define-values (numberer-str new-val)
+ (let ([step (numberer-step-proc n)])
+ (step (hash-ref ht tag (lambda () (numberer-initial-value n)))
+ parent-numbers)))
+ (values numberer-str (hash-set ht tag new-val)))
+
+(define part-number-item?
+ (or/c #f exact-nonnegative-integer? string? (list/c string? string?)))
+
+(provide
+ part-number-item?
+ numberer?
+ (contract-out
+ [make-numberer ((any/c (listof part-number-item?)
+ . -> . (values part-number-item? any/c))
+ any/c
+ . -> . numberer?)]
+ [numberer-step (numberer?
+ (listof part-number-item?)
+ collect-info?
+ hash?
+ . -> . (values part-number-item? hash?))]))
+
+;; ----------------------------------------
+
(provide-structs
[part ([tag-prefix (or/c false/c string?)]
[tags (listof tag?)]
@@ -211,6 +262,7 @@
[target-url ([addr path-string?])]
[color-property ([color (or/c string? (list/c byte? byte? byte?))])]
[background-color-property ([color (or/c string? (list/c byte? byte? byte?))])]
+ [numberer-property ([numberer numberer?] [argument any/c])]
[table-columns ([styles (listof style?)])]
[table-cells ([styless (listof (listof style?))])]
@@ -219,7 +271,7 @@
[center-name string?]
[bottom-name string?])]
- [collected-info ([number (listof (or/c false/c exact-nonnegative-integer? string?))]
+ [collected-info ([number (listof part-number-item?)]
[parent (or/c false/c part?)]
[info any/c])]
diff --git a/scribble-lib/scribble/html-render.rkt b/scribble-lib/scribble/html-render.rkt
@@ -341,12 +341,12 @@
;; ----------------------------------------
(define/override (start-collect ds fns ci)
- (map (lambda (d fn)
- (parameterize ([current-output-file fn]
- [current-top-part d])
- (collect-part d #f ci null 1)))
- ds
- fns))
+ (for-each (lambda (d fn)
+ (parameterize ([current-output-file fn]
+ [current-top-part d])
+ (collect-part d #f ci null 1 #hash())))
+ ds
+ fns))
(define/public (part-whole-page? p ri)
(let ([dest (resolve-get p ri (car (part-tags/nonempty p)))])
@@ -1906,14 +1906,14 @@
(define/override (start-collect ds fns ci)
(parameterize ([current-part-files (make-hash)])
- (map (lambda (d fn)
- (parameterize ([collecting-sub
- (if (part-style? d 'non-toc)
- 1
- 0)])
- (super start-collect (list d) (list fn) ci)))
- ds
- fns)))
+ (for-each (lambda (d fn)
+ (parameterize ([collecting-sub
+ (if (part-style? d 'non-toc)
+ 1
+ 0)])
+ (super start-collect (list d) (list fn) ci)))
+ ds
+ fns)))
(define/private (check-duplicate-filename orig-s)
(let ([s (string-downcase (path->string orig-s))])
@@ -1922,7 +1922,7 @@
orig-s))
(hash-set! (current-part-files) s #t)))
- (define/override (collect-part d parent ci number sub-init-number)
+ (define/override (collect-part d parent ci number sub-init-number sub-init-numberers)
(let ([prev-sub (collecting-sub)])
(parameterize ([collecting-sub (if (part-style? d 'toc)
1
@@ -1936,8 +1936,8 @@
(make-directory* (path-only full-filename))
(check-duplicate-filename full-filename)
(parameterize ([current-output-file full-filename])
- (super collect-part d parent ci number sub-init-number)))
- (super collect-part d parent ci number sub-init-number)))))
+ (super collect-part d parent ci number sub-init-number sub-init-numberers)))
+ (super collect-part d parent ci number sub-init-number sub-init-numberers)))))
(define/override (render-top ds fns ri)
(map (lambda (d fn)
diff --git a/scribble-lib/scribble/markdown-render.rkt b/scribble-lib/scribble/markdown-render.rkt
@@ -41,9 +41,9 @@
(let ([number (collected-info-number (part-collected-info d ht))])
(unless (part-style? d 'hidden)
(printf (string-append (make-string (add1 (number-depth number)) #\#) " "))
- (let ([s (format-number number '())])
+ (let ([s (format-number number '() #t)])
(unless (null? s)
- (printf "~a.~a"
+ (printf "~a~a"
(car s)
(if (part-title-content d)
" "
diff --git a/scribble-lib/scribble/text-render.rkt b/scribble-lib/scribble/text-render.rkt
@@ -37,9 +37,9 @@
(define/override (render-part d ht)
(let ([number (collected-info-number (part-collected-info d ht))])
(unless (part-style? d 'hidden)
- (let ([s (format-number number '())])
+ (let ([s (format-number number '() #t)])
(unless (null? s)
- (printf "~a.~a"
+ (printf "~a~a"
(car s)
(if (part-title-content d)
" "
diff --git a/scribble-test/tests/scribble/docs/numberer.scrbl b/scribble-test/tests/scribble/docs/numberer.scrbl
@@ -0,0 +1,37 @@
+#lang scribble/base
+@(require scribble/core)
+
+@(define P (make-numberer (lambda (v parent-number)
+ (values (list (format "[~a]" v) ; number in brackets
+ "") ; no separator afterward
+ (add1 v))) ; increment section number
+ 1)) @; count from 1
+@(define PL (make-numberer (lambda (v parent-number)
+ (values (list (if (null? parent-number)
+ (string v) ; top-level section is uppercase
+ (string-downcase (string v))) ; nested is lowercase
+ ",") ; "," as separator
+ (integer->char (add1 (char->integer v))))) ; increment letter
+ #\A)) @; count from A
+
+@(define (P-section . s) (section #:style (style #f (list P)) s))
+@(define (PL-section . s) (section #:style (style #f (list PL)) s))
+@(define (PL-subsection . s) (subsection #:style (style #f (list PL)) s))
+
+@title{Two Tracks}
+
+@P-section{Px}
+
+@PL-section{Py}
+
+@PL-section{PLx}
+
+@P-section{Pz}
+@PL-subsection{PL-subx}
+@subsection{Normal}
+@PL-subsection{PL-suby}
+
+@PL-section{PLy}
+
+@PL-section{PLz}
+@subsection{Normal2}
diff --git a/scribble-test/tests/scribble/docs/numberer.txt b/scribble-test/tests/scribble/docs/numberer.txt
@@ -0,0 +1,29 @@
+Two Tracks
+
+[1] Px
+
+
+A, Py
+
+
+B, PLx
+
+
+[2] Pz
+
+[2]a, PL-subx
+
+
+[2]1. Normal
+
+
+[2]b, PL-suby
+
+
+C, PLy
+
+
+D, PLz
+
+D,1. Normal2
+
