Add a convenient macro for sections, and some sequence functions
This commit is contained in:
parent
e54d7c0806
commit
6158e24d84
|
@ -20,3 +20,108 @@
|
|||
(provide TT)
|
||||
(define (TT . xs)
|
||||
@tt[style: "background-color: #dde;"]{@xs})
|
||||
|
||||
;; some tags with convenient separators
|
||||
(provide make-separated-tag (rename-out [the-separator ~])
|
||||
p* ul* ol* dl*)
|
||||
(struct separator ())
|
||||
(define the-separator (separator))
|
||||
(define (split-list-by-separator list)
|
||||
;; The idea is to drop all whitespace around the separator, and then drop the
|
||||
;; common leading all-space prefixes in each chunk, so the separators are
|
||||
;; effectively ignored for indentation in the output. This is too much for
|
||||
;; html output (leaving the whitespaces in what this is used for is
|
||||
;; harmless), but it might be useful for some future application.
|
||||
(define (drop-ws list left?)
|
||||
(if (and (pair? list) (string? (car list)))
|
||||
(let ([str (regexp-replace (if left? #rx"^[ \t\r\n]+" #rx"[ \t\r\n]+$")
|
||||
(car list) "")])
|
||||
(if (equal? "" str) (drop-ws (cdr list) left?) (cons str (cdr list))))
|
||||
list))
|
||||
(define (drop-indentation/reverse orig-text)
|
||||
(define N #f)
|
||||
(if (null? orig-text)
|
||||
orig-text
|
||||
(let loop ([text orig-text] [r '()])
|
||||
(cond [(null? (cdr text))
|
||||
(if N (cons (car text) r) (reverse orig-text))]
|
||||
[(not (equal? "\n" (cadr text)))
|
||||
(loop (cdr text) (cons (car text) r))]
|
||||
[(not (and (string? (car text))
|
||||
(regexp-match? #rx"^ +$" (car text))))
|
||||
(reverse orig-text)]
|
||||
[else (let ([len (string-length (cadr text))])
|
||||
(set! N (if N (min len N) len))
|
||||
(loop (cddr text)
|
||||
(list* (lambda () (make-string (- len N) #\space))
|
||||
"\n" r)))]))))
|
||||
(let loop ([list (drop-ws list #t)] [cur '()] [r '()])
|
||||
(define (get-r) (cons (drop-indentation/reverse (drop-ws cur #f)) r))
|
||||
(cond [(null? list) (reverse (get-r))]
|
||||
[(separator? (car list)) (loop (drop-ws (cdr list) #t) '() (get-r))]
|
||||
[else (loop (cdr list) (cons (car list) cur) r)])))
|
||||
(define ((make-separated-tag wrapper #:newlines? [nls? #t] . tags) . body)
|
||||
(let* ([chunks (split-list-by-separator body)]
|
||||
[chunks (if (null? (car chunks)) (cdr chunks) chunks)]
|
||||
[body (for/list ([text (in-list chunks)]
|
||||
[tag (in-cycle (in-list tags))])
|
||||
(tag text))]
|
||||
[body (if nls? (add-newlines body) body)])
|
||||
(wrapper body)))
|
||||
(define p* (make-separated-tag values p))
|
||||
(define ul* (make-separated-tag ul li))
|
||||
(define ol* (make-separated-tag ol li))
|
||||
(define dl* (make-separated-tag dl dt dd))
|
||||
|
||||
;; conditional display on screen or print
|
||||
(provide printonly screenonly)
|
||||
(define (printonly . body) (apply div class: 'printonly body))
|
||||
(define (screenonly . body) (apply div class: 'screenonly body))
|
||||
|
||||
;; (sections) defines a `section' function and spits out a (delayed) table of
|
||||
;; contents for all its future uses in the page.
|
||||
(provide sections)
|
||||
(require (for-syntax racket/base))
|
||||
(define (section->label title)
|
||||
(regexp-replace* #rx"[^a-z0-9_]+" (string-downcase title) "_"))
|
||||
(define (make-sectioner #:toc? [toc? #t]
|
||||
#:newpages? [newpages? #f]
|
||||
#:show-section-in-subtitle [sec-in-subsec? #t])
|
||||
(define sections '())
|
||||
(define cur-sec #f)
|
||||
(define subsections '())
|
||||
(define (->li/reverse items [more-style #f])
|
||||
(ul style: more-style (add-newlines (map li (reverse items)))))
|
||||
(define (collect-subs)
|
||||
(when (pair? subsections)
|
||||
(set! sections
|
||||
(cons (list (car sections)
|
||||
(->li/reverse subsections "font-size: small;"))
|
||||
(cdr sections)))
|
||||
(set! subsections '())))
|
||||
(define ((add-section sub?) #:newpage? [newpage? newpages?] . title)
|
||||
(let* ([title* (if sub? (list cur-sec ": " title) title)]
|
||||
[label (section->label (xml->string title*))])
|
||||
(unless sub? (collect-subs) (set! cur-sec title))
|
||||
(let ([title (a href: (list "#" label) style: "text-decoration: none;"
|
||||
title)])
|
||||
(if sub?
|
||||
(set! subsections (cons title subsections))
|
||||
(set! sections (cons title sections))))
|
||||
((if sub? h2 h1)
|
||||
(a name: label
|
||||
style: (and newpage? (pair? (cdr sections))
|
||||
"page-break-before: always;")
|
||||
(if sec-in-subsec? title* title)))))
|
||||
(values (add-section #f) (add-section #t)
|
||||
(and toc? (lambda () (collect-subs) (->li/reverse sections)))))
|
||||
(define-syntax (sections stx)
|
||||
(define (make-it stx args)
|
||||
(with-syntax ([sec (datum->syntax stx 'section)]
|
||||
[sub (datum->syntax stx 'subsection)]
|
||||
[(x ...) args])
|
||||
#'(begin (define-values [sec sub toc] (make-sectioner x ...))
|
||||
toc)))
|
||||
(syntax-case stx ()
|
||||
[(s x ...) (make-it #'s #'(x ...))]
|
||||
[_ (identifier? stx) (make-it stx #'())]))
|
||||
|
|
Loading…
Reference in New Issue
Block a user