diff --git a/collects/scribblings/scribble/utils.ss b/collects/scribblings/scribble/utils.ss index a1f581a0..18e09088 100644 --- a/collects/scribblings/scribble/utils.ss +++ b/collects/scribblings/scribble/utils.ss @@ -1,120 +1,102 @@ +#lang scheme/base -(module utils scheme/base - (require scribble/struct - scribble/manual - (prefix-in scheme: scribble/scheme) - (prefix-in scribble: scribble/reader)) +(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) ...)])) +(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) +(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) +(provide scribble-examples litchar/lines) - (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) - (list (make-flow (list (make-paragraph - (if (string=? s "") - '(nbsp) ; needed for IE - (list (litchar s)))))))) - strs))))) +(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) + (let ([line (if (string=? s "") + '(nbsp) ; needed for IE + (list (litchar s)))]) + (list (make-flow (list (make-paragraph line)))))) + strs))))) - (define (as-flow e) - (make-flow (list (if (block? e) - e - (make-paragraph (list e)))))) +(define (as-flow e) + (make-flow (list (if (block? e) e (make-paragraph (list e)))))) - (define spacer (hspace 2)) +(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]) - (cond - [(null? e) - (datum->syntax - p - (reverse accum) - (list (syntax-source p) - (syntax-line p) - base - (add1 base) - (- pos base)) - p)] - [else - (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 ((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))))))))) +(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))))))))