133 lines
5.6 KiB
Racket
133 lines
5.6 KiB
Racket
#lang at-exp racket/base
|
|
|
|
(require scribble/html)
|
|
|
|
;; list of a header paragraphs and sub paragraphs (don't use `p' since it looks
|
|
;; like they should not be nested)
|
|
(provide parlist)
|
|
(define (parlist first . rest)
|
|
(list (div class: 'parlisttitle first)
|
|
(map (λ (p) (div class: 'parlistitem p)) rest)))
|
|
|
|
;; a div that is centered, but the text is still left-justified
|
|
(provide center-div)
|
|
(define (center-div . text)
|
|
(let-values ([(attrs body) (split-attributes+body text)])
|
|
(apply div align: 'center
|
|
(append attrs
|
|
(list (div align: 'left style: "display: inline-block;"
|
|
body))))))
|
|
|
|
;; a grayish tt text
|
|
(provide TT)
|
|
(define (TT . xs)
|
|
@tt[style: "background-color: #d8d8e8;"]{@xs})
|
|
(provide PRE)
|
|
(define (PRE . xs)
|
|
@pre[style: "background-color: #d8d8e8;"]{@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* (λ () (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))])
|
|
(apply 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? (λ () (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 #'())]))
|