pollen/scribblings/utils.rkt

262 lines
11 KiB
Racket

#lang racket/base
(require scribble/core
scribble/html-properties
scribble/manual
(prefix-in racket: scribble/racket)
(prefix-in scribble: scribble/reader)
(prefix-in pollen: (submod pollen reader)))
(define-syntax bounce-for-label
(syntax-rules (all-except)
[(_ (all-except mod (id ...) (id2 ...)))
(begin (require (for-label (except-in mod id ...)))
(provide (for-label (except-out (all-from-out mod) id2 ...))))]
[(_ mod) (begin (require (for-label mod))
(provide (for-label (all-from-out mod))))]
[(_ mod ...) (begin (bounce-for-label mod) ...)]))
(bounce-for-label (all-except racket (abstract link) ())
scribble/core
scribble/base-render
scribble/decode
scribble/manual
scribble/racket
scribble/html-properties
scribble/latex-properties
scribble/eval
scribble/bnf)
(provide scribble-examples pollen-examples litchar/lines doc-render-examples)
(define (as-flow e)
(if (block? e) e (make-paragraph plain (list e))))
(define (litchar/lines . strs)
(let ([strs (regexp-split #rx"\n" (apply string-append strs))])
(if (= 1 (length strs))
(litchar (car strs))
(make-table
plain
(map (lambda (s) ; the nbsp is needed for IE
(list (as-flow (if (string=? s "") 'nbsp (litchar s)))))
strs)))))
(define spacer (hspace 2))
(define ((norm-spacing base) p)
(cond [(and (syntax->list p) (not (null? (syntax-e p))))
(let loop ([e (syntax->list p)]
[line (syntax-line (car (syntax-e p)))]
[pos base]
[second #f]
[accum null])
(if (null? e)
(datum->syntax
p (reverse accum)
(list (syntax-source p) (syntax-line p) base (add1 base)
(- pos base))
p)
(let* ([v ((norm-spacing (if (= line (syntax-line (car e)))
pos
(or second pos)))
(car e))]
[next-pos (+ (syntax-column v) (syntax-span v) 1)])
(loop (cdr e)
(syntax-line v)
next-pos
(or second next-pos)
(cons v accum)))))]
[else (datum->syntax
p (syntax-e p)
(list (syntax-source p) (syntax-line p) base (add1 base) 1)
p)]))
(define (pollen-examples . lines)
(define reads-as (make-paragraph plain (list spacer "reads as" spacer)))
(let* ([lines (apply string-append lines)]
[p (open-input-string lines)])
(port-count-lines! p)
(let loop ([r '()] [newlines? #f])
(regexp-match? #px#"^[[:space:]]*" p)
(let* ([p1 (file-position p)]
[stx (pollen:read-syntax #f p)]
[p2 (file-position p)])
(if (not (eof-object? stx))
(let ([str (substring lines p1 p2)])
(loop (cons (list str stx) r)
(or newlines? (regexp-match? #rx#"\n" str))))
(let* ([r (reverse r)]
[r (if newlines?
(cdr (apply append (map (lambda (x) (list #f x)) r)))
r)])
(make-table
plain
(map (lambda (x)
(let ([@expr (if x (litchar/lines (car x)) "")]
[sexpr (if x
(racket:to-paragraph
((norm-spacing 0) (cadr x)))
"")]
[reads-as (if x reads-as "")])
(map as-flow (list spacer @expr reads-as sexpr))))
r))))))))
(define (scribble-examples . lines)
(define reads-as (make-paragraph plain (list spacer "reads as" spacer)))
(let* ([lines (apply string-append lines)]
[p (open-input-string lines)])
(port-count-lines! p)
(let loop ([r '()] [newlines? #f])
(regexp-match? #px#"^[[:space:]]*" p)
(let* ([p1 (file-position p)]
[stx (scribble:read-syntax #f p)]
[p2 (file-position p)])
(if (not (eof-object? stx))
(let ([str (substring lines p1 p2)])
(loop (cons (list str stx) r)
(or newlines? (regexp-match? #rx#"\n" str))))
(let* ([r (reverse r)]
[r (if newlines?
(cdr (apply append (map (lambda (x) (list #f x)) r)))
r)])
(make-table
plain
(map (lambda (x)
(let ([@expr (if x (litchar/lines (car x)) "")]
[sexpr (if x
(racket:to-paragraph
((norm-spacing 0) (cadr x)))
"")]
[reads-as (if x reads-as "")])
(map as-flow (list spacer @expr reads-as sexpr))))
r))))))))
;; stuff for the scribble/text examples
(require racket/list (for-syntax racket/base racket/list))
(define max-textsample-width 45)
(define (textsample-verbatim-boxes line in-text out-text more)
(define (split str) (regexp-split #rx"\n" str))
(define strs1 (split in-text))
(define strs2 (split out-text))
(define strsm (map (compose split cdr) more))
(define (str->elts str)
(let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)])
(if spaces
(list* (str->elts (substring str 0 (caar spaces)))
(smaller (hspace (- (cdar spaces) (caar spaces))))
(str->elts (substring str (cdar spaces))))
(list (smaller (make-element 'tt str))))))
(define (make-line str)
(list (as-flow (if (equal? str "")
(smaller (hspace 1))
(str->elts str)))))
(define (make-box strs [file #f])
(nested #:style 'code-inset
(let ([t (make-table plain (map make-line strs))])
(if file
(filebox file t)
t))))
(define filenames (map car more))
(define indent (let ([d (- max-textsample-width
(for*/fold ([m 0])
([s (in-list (cons strs1 strsm))]
[s (in-list s)])
(max m (string-length s))))])
(if (negative? d)
(error 'textsample-verbatim-boxes
"left box too wide for sample at line ~s" line)
(make-element 'tt (list (hspace d))))))
;; Note: the font-size property is reset for every table, so we need it
;; everywhere there's text, and they don't accumulate for nested tables
(values
(make-table
(make-style #f
(list (make-table-columns (list (make-style #f '(left top))))))
(cons (list (as-flow (make-box strs1)))
(map (lambda (file strs)
(list (as-flow (make-box strs file))))
filenames strsm)))
(make-box strs2)))
(define (textsample line in-text out-text more)
(define-values (box1 box2)
(textsample-verbatim-boxes line in-text out-text more))
(make-table
(make-style #f (list (make-table-columns (list (make-style #f '(left vcenter))
(make-style "Short" '(left vcenter))
(make-style #f '(left vcenter))))))
(list (map as-flow (list box1 (make-paragraph plain '(nbsp rarr nbsp)) box2)))))
(define-for-syntax tests-ids #f)
(provide initialize-tests)
(define-syntax (initialize-tests stx)
(set! tests-ids (map (lambda (x) (datum->syntax stx x stx))
'(tests add-to-tests)))
(with-syntax ([(tests add-to-tests) tests-ids])
#'(begin (provide tests)
(define-values (tests add-to-tests)
(let ([l '()])
(values (lambda () (reverse l))
(lambda (x) (set! l (cons x l)))))))))
(provide example)
(define-syntax (example stx)
(define sep-rx #px"^---[*]{3}---(?: +(.*))?$")
(define file-rx #rx"^[a-z0-9_.+-]+$")
(define-values (body hidden?)
(syntax-case stx ()
[(_ #:hidden x ...) (values #'(x ...) #t)]
[(_ x ...) (values #'(x ...) #f)]))
(let loop ([xs body] [text '(#f)] [texts '()])
(syntax-case xs ()
[("\n" sep "\n" . xs)
(and (string? (syntax-e #'sep)) (regexp-match? sep-rx (syntax-e #'sep)))
(let ([m (cond [(regexp-match sep-rx (syntax-e #'sep)) => cadr]
[else #f])])
(if (and m (not (regexp-match? file-rx m)))
(raise-syntax-error #f "bad filename specified" stx #'sep)
(loop #'xs
(list (and m (datum->syntax #'sep m #'sep #'sep)))
(cons (reverse text) texts))))]
[(x . xs) (loop #'xs (cons #'x text) texts)]
[() (let ([texts (reverse (cons (reverse text) texts))]
[line (syntax-line stx)])
(define-values (files i/o) (partition car texts))
(unless ((length i/o) . = . 2)
(raise-syntax-error
'example "need at least an input and an output block" stx))
(with-syntax ([line line]
[((in ...) (out ...)) (map cdr i/o)]
[((file text ...) ...) files]
[add-to-tests (cadr tests-ids)])
(quasisyntax/loc stx
(let* ([in-text (string-append in ...)]
[out-text (string-append out ...)]
[more (list (cons file (string-append text ...)) ...)])
(add-to-tests (list line in-text out-text more))
#,(if hidden? #'""
#'(textsample line in-text out-text more))))))]
[_ (raise-syntax-error #f "no separator found in example text")])))
(provide ltx ltxe ltxd)
(define (ltx s) (tt "\\" s)) ; command
(define (ltxe s) (tt s)) ; enviornment
(define (ltxd n s)
(make-element #f (cons (index (list s) (ltx s))
(for/list ([i (in-range n)]) (tt "{}")))))
;; Utility to render examples of scribble documentation forms
;; Note: it would be nice if this abstracted over the codeblock
;; that usually comes along with this too, but that's hard
;; because there's a read-time distinction between [...]
;; and |{...}|.
(define-syntax-rule (doc-render-examples e ...)
(nested "Renders like:\n"
(nested #:style 'inset (nested #:style 'inset e ...))))