From 6158e24d843feeaa68f2269f5c8d80fbbb942fd3 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Thu, 8 Jul 2010 18:20:16 -0400
Subject: [PATCH] Add a convenient macro for sections, and some sequence
 functions

---
 collects/meta/web/common/extras.rkt | 105 ++++++++++++++++++++++++++++
 1 file changed, 105 insertions(+)

diff --git a/collects/meta/web/common/extras.rkt b/collects/meta/web/common/extras.rkt
index db371e79b9..77945514d3 100644
--- a/collects/meta/web/common/extras.rkt
+++ b/collects/meta/web/common/extras.rkt
@@ -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 #'())]))