198 lines
8.0 KiB
Scheme
198 lines
8.0 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scribble/struct
|
|
scribble/manual
|
|
(prefix-in scheme: scribble/scheme)
|
|
(prefix-in scribble: scribble/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 scheme (link) ())
|
|
scribble/struct
|
|
scribble/base-render
|
|
scribble/decode
|
|
scribble/manual
|
|
scribble/scheme
|
|
scribble/eval
|
|
scribble/bnf)
|
|
|
|
(provide scribble-examples litchar/lines)
|
|
|
|
(define (as-flow e)
|
|
(make-flow (list (if (block? e) e (make-paragraph (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
|
|
#f
|
|
(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 (scribble-examples . lines)
|
|
(define reads-as (make-paragraph (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
|
|
#f
|
|
(map (lambda (x)
|
|
(let ([@expr (if x (litchar/lines (car x)) "")]
|
|
[sexpr (if x
|
|
(scheme: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 preprocessor examples
|
|
|
|
(require scheme/list (for-syntax scheme/base scheme/list))
|
|
|
|
(define max-textsample-width 35)
|
|
|
|
(define (textsample-verbatim-boxes line 1st 2nd more)
|
|
(define (split str) (regexp-split #rx"\n" str))
|
|
(define strs1 (split 1st))
|
|
(define strs2 (split 2nd))
|
|
(define strsm (map (compose split cdr) more))
|
|
(define (str->elts str)
|
|
(let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)])
|
|
(if spaces
|
|
(list* (substring str 0 (caar spaces))
|
|
(hspace (- (cdar spaces) (caar spaces)))
|
|
(str->elts (substring str (cdar spaces))))
|
|
(list (make-element 'tt (list str))))))
|
|
(define (make-line str) (list (as-flow (make-element 'tt (str->elts str)))))
|
|
(define (make-box strs) (make-table 'boxed (map make-line strs)))
|
|
(define box1 (make-box strs1))
|
|
(define box2 (make-box strs2))
|
|
(define boxm (map make-box strsm))
|
|
(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)
|
|
(hspace d))))
|
|
(values
|
|
(make-table '([alignment right left] [valignment top top])
|
|
(cons (list (as-flow indent) (as-flow box1))
|
|
(map (lambda (file strs)
|
|
(let* ([file (make-element 'tt (list file ":" 'nbsp))]
|
|
[file (list (make-element 'italic (list file)))])
|
|
(list (as-flow (make-element '(bg-color 232 232 255) file))
|
|
(as-flow (make-box strs)))))
|
|
filenames strsm)))
|
|
box2))
|
|
|
|
(define (textsample line 1st 2nd . more)
|
|
(define-values (box1 box2) (textsample-verbatim-boxes line 1st 2nd more))
|
|
(make-table '([alignment left left left] [valignment center center center])
|
|
(list (map as-flow (list box1 (make-paragraph '(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_.+-]+$")
|
|
(syntax-case stx ()
|
|
[(_ x ...)
|
|
(let loop ([xs #'(x ...)] [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]
|
|
[((i/o ...) ...) (map cdr i/o)]
|
|
[((file text ...) ...) files]
|
|
[add-to-tests (cadr tests-ids)])
|
|
(syntax/loc stx
|
|
(let ([t (list line (string-append i/o ...) ...
|
|
(cons file (string-append text ...)) ...)])
|
|
(add-to-tests t)
|
|
(apply textsample t)))))]
|
|
[_ (raise-syntax-error #f "no separator found in example text")]))]))
|