diff --git a/scribble-doc/scribblings/scribble/class-diagrams.rkt b/scribble-doc/scribblings/scribble/class-diagrams.rkt index 5f13dff7e6..0b94225a96 100644 --- a/scribble-doc/scribblings/scribble/class-diagrams.rkt +++ b/scribble-doc/scribblings/scribble/class-diagrams.rkt @@ -70,41 +70,32 @@ (unless (even? (length args)) (error 'method-spec "expected a list of types and argument names, but found ~a arguments" (length args))) - (let ([first-line - (hbl-append - (type-spec range) - (normal-font " ") - (var-font name) - (cond - [(null? args) - (normal-font "()")] - [else - (hbl-append - (normal-font "(") - (let loop ([args args]) - (let* ([type (car args)] - [param (cadr args)] - [single-arg - (if param - (hbl-append (type-spec type) - (normal-font " ") - (var-font param)) - (type-spec type))]) - - (cond - [(null? (cddr args)) - (hbl-append single-arg (normal-font ")"))] - [else - (hbl-append single-arg - (normal-font ", ") - (loop (cddr args)))]))))]) - (if body - (hbl-append (normal-font " {")) - (blank)))]) - (if body - (vl-append first-line - (hbl-append (blank 8 0) body (normal-font "}"))) - first-line))) + (define first-line + (hbl-append + (type-spec range) + (normal-font " ") + (var-font name) + (cond + [(null? args) (normal-font "()")] + [else + (hbl-append + (normal-font "(") + (let loop ([args args]) + (let* ([type (car args)] + [param (cadr args)] + [single-arg (if param + (hbl-append (type-spec type) (normal-font " ") (var-font param)) + (type-spec type))]) + + (cond + [(null? (cddr args)) (hbl-append single-arg (normal-font ")"))] + [else (hbl-append single-arg (normal-font ", ") (loop (cddr args)))]))))]) + (if body + (hbl-append (normal-font " {")) + (blank)))) + (if body + (vl-append first-line (hbl-append (blank 8 0) body (normal-font "}"))) + first-line)) (define (type-spec str) (cond @@ -126,83 +117,86 @@ ;; class-box : pict (or/c #f (listof pict)) (or/c #f (listof pict)) -> pict (define (class-box name fields methods) - (let* ([mk-blank (λ () (blank 0 (+ class-box-margin class-box-margin)))]) - (cond - [(and methods fields) - (let* ([top-spacer (mk-blank)] - [bottom-spacer (mk-blank)] - [main (vl-append name - top-spacer - (if (null? fields) - (blank 0 4) - (apply vl-append fields)) - bottom-spacer - (if (null? methods) - (blank 0 4) - (apply vl-append methods)))]) - (add-hline - (add-hline (frame (inset main class-box-margin)) - top-spacer) - bottom-spacer))] - [fields - (let* ([top-spacer (mk-blank)] - [main (vl-append name - top-spacer - (if (null? fields) - (blank) - (apply vl-append fields)))]) - (add-hline (frame (inset main class-box-margin)) - top-spacer))] - [methods (class-box name methods fields)] - [else (frame (inset name class-box-margin))]))) + (define (mk-blank) + (blank 0 (+ class-box-margin class-box-margin))) + (cond + [(and methods fields) + (let* ([top-spacer (mk-blank)] + [bottom-spacer (mk-blank)] + [main (vl-append name + top-spacer + (if (null? fields) + (blank 0 4) + (apply vl-append fields)) + bottom-spacer + (if (null? methods) + (blank 0 4) + (apply vl-append methods)))]) + (add-hline (add-hline (frame (inset main class-box-margin)) top-spacer) bottom-spacer))] + [fields + (let* ([top-spacer (mk-blank)] + [main (vl-append name + top-spacer + (if (null? fields) + (blank) + (apply vl-append fields)))]) + (add-hline (frame (inset main class-box-margin)) top-spacer))] + [methods (class-box name methods fields)] + [else (frame (inset name class-box-margin))])) (define (add-hline main sub) - (let-values ([(x y) (cc-find main sub)]) - (pin-line main - sub (λ (p1 p2) (values 0 y)) - sub (λ (p1 p2) (values (pict-width main) y))))) + (define-values (x y) (cc-find main sub)) + (pin-line main sub (λ (p1 p2) (values 0 y)) sub (λ (p1 p2) (values (pict-width main) y)))) ;; hierarchy : pict (cons pict (listof pict)) (cons pict (listof pict)) -> pict (define (hierarchy main supers subs) - (let ([supers-bottoms (apply max (map (λ (x) (let-values ([(x y) (cb-find main x)]) y)) supers))] - [subs-tops (apply min (map (λ (x) (let-values ([(x y) (ct-find main x)]) y)) subs))] - [sorted-subs (sort subs (λ (x y) (< (left-edge-x main x) (left-edge-x main y))))]) - (unless (< supers-bottoms subs-tops) - (error 'hierarchy "expected supers to be on top of subs, supers bottom is at ~a, and subs tops is at ~a" - supers-bottoms - subs-tops)) - (let* ([main-line-y (max (- subs-tops 20) (/ (+ supers-bottoms subs-tops) 2))] - [main-line-start-x (center-x main (car sorted-subs))] - [main-line-end-x (center-x main (last sorted-subs))] - [w/main-line - (pin-line main - main (λ (_1 _2) (values main-line-start-x main-line-y)) - main (λ (_1 _2) (values main-line-end-x main-line-y)) - #:color hierarchy-color)] - [super-lines - (map (λ (super) - (let-values ([(x y) (cb-find main super)]) - (pin-over - (pin-line (ghost main) - super cb-find - main (λ (_1 _2) (values x main-line-y))) - (- x (/ (pict-width triangle) 2)) - (- (/ (+ y main-line-y) 2) - (/ (pict-height triangle) 2)) - triangle))) - supers)] - [sub-lines - (map (λ (sub) - (let-values ([(x y) (ct-find main sub)]) - (pin-line (ghost main) - sub ct-find - main (λ (_1 _2) (values x main-line-y)) - #:color hierarchy-color))) - subs)]) - (apply cc-superimpose - w/main-line - (append sub-lines - super-lines))))) + (define supers-bottoms + (apply max + (map (λ (x) + (let-values ([(x y) (cb-find main x)]) + y)) + supers))) + (define subs-tops + (apply min + (map (λ (x) + (let-values ([(x y) (ct-find main x)]) + y)) + subs))) + (define sorted-subs (sort subs (λ (x y) (< (left-edge-x main x) (left-edge-x main y))))) + (unless (< supers-bottoms subs-tops) + (error 'hierarchy + "expected supers to be on top of subs, supers bottom is at ~a, and subs tops is at ~a" + supers-bottoms + subs-tops)) + (define main-line-y (max (- subs-tops 20) (/ (+ supers-bottoms subs-tops) 2))) + (define main-line-start-x (center-x main (car sorted-subs))) + (define main-line-end-x (center-x main (last sorted-subs))) + (define w/main-line + (pin-line main + main + (λ (_1 _2) (values main-line-start-x main-line-y)) + main + (λ (_1 _2) (values main-line-end-x main-line-y)) + #:color hierarchy-color)) + (define super-lines + (map (λ (super) + (let-values ([(x y) (cb-find main super)]) + (pin-over (pin-line (ghost main) super cb-find main (λ (_1 _2) (values x main-line-y))) + (- x (/ (pict-width triangle) 2)) + (- (/ (+ y main-line-y) 2) (/ (pict-height triangle) 2)) + triangle))) + supers)) + (define sub-lines + (map (λ (sub) + (let-values ([(x y) (ct-find main sub)]) + (pin-line (ghost main) + sub + ct-find + main + (λ (_1 _2) (values x main-line-y)) + #:color hierarchy-color))) + subs)) + (apply cc-superimpose w/main-line (append sub-lines super-lines))) (define triangle-width 12) (define triangle-height 12) @@ -212,49 +206,47 @@ (make-object point% triangle-width triangle-height))]) (colorize (dc (λ (dc dx dy) - (let ([brush (send dc get-brush)]) - (send dc set-brush (send brush get-color) 'solid) - (send dc draw-polygon points dx dy) - (send dc set-brush brush))) + (define brush (send dc get-brush)) + (send dc set-brush (send brush get-color) 'solid) + (send dc draw-polygon points dx dy) + (send dc set-brush brush)) triangle-width triangle-height) hierarchy-color))) (define (center-x main pict) - (let-values ([(x y) (cc-find main pict)]) - x)) + (define-values (x y) (cc-find main pict)) + x) (define (left-edge-x main pict) - (let-values ([(x y) (lc-find main pict)]) - x)) + (define-values (x y) (lc-find main pict)) + x) (define (add-dot-right main class field) (add-dot-left-right/offset main class field 0 rc-find)) -(define add-dot-right/space - (λ (main class field [count 1]) - (add-dot-right/offset main class field (* count dot-edge-spacing)))) +(define (add-dot-right/space main class field [count 1]) + (add-dot-right/offset main class field (* count dot-edge-spacing))) (define (add-dot-right/offset main class field offset) (add-dot-left-right/offset main class field offset rc-find)) (define (add-dot-left main class field) (add-dot-left-right/offset main class field 0 lc-find)) -(define add-dot-left/space - (λ (main class field [count 1]) - (add-dot-left/offset main class field (* count (- dot-edge-spacing))))) +(define (add-dot-left/space main class field [count 1]) + (add-dot-left/offset main class field (* count (- dot-edge-spacing)))) (define (add-dot-left/offset main class field offset) (add-dot-left-right/offset main class field offset lc-find)) (define (add-dot-left-right/offset main class field offset finder) - (let-values ([(_1 y) (cc-find main field)] - [(x-edge _2) (finder main class)]) - (add-dot main (+ x-edge offset) y))) + (define-values (_1 y) (cc-find main field)) + (define-values (x-edge _2) (finder main class)) + (add-dot main (+ x-edge offset) y)) (define add-dot-junction (case-lambda [(main x-pict y-pict) (add-dot-junction main x-pict cc-find y-pict cc-find)] [(main x-pict x-find y-pict y-find) - (let-values ([(x _1) (x-find main x-pict)] - [(_2 y) (y-find main y-pict)]) - (add-dot main x y))])) + (define-values (x _1) (x-find main x-pict)) + (define-values (_2 y) (y-find main y-pict)) + (add-dot main x y)])) (define (add-dot-offset pict dot dx dy) (let-values ([(x y) (cc-find pict dot)]) diff --git a/scribble-lib/scribble/lp/lang/common.rkt b/scribble-lib/scribble/lp/lang/common.rkt index 266e5c3589..396655a97b 100644 --- a/scribble-lib/scribble/lp/lang/common.rkt +++ b/scribble-lib/scribble/lp/lang/common.rkt @@ -24,7 +24,7 @@ (cons id (mapping-get chunk-groups id))) (free-identifier-mapping-put! chunks id - `(,@(mapping-get chunks id) ,@exprs)))) + (append (mapping-get chunks id) exprs)))) (define-syntax (tangle stx) (define chunk-mentions '()) diff --git a/scribble-test/tests/scribble/markdown.rkt b/scribble-test/tests/scribble/markdown.rkt index 8cc7dd7033..cb16eb657a 100644 --- a/scribble-test/tests/scribble/markdown.rkt +++ b/scribble-test/tests/scribble/markdown.rkt @@ -10,14 +10,14 @@ "scribble-docs-tests")) (define (build-markdown-doc src-file dest-file) - (let* ([renderer (new (markdown:render-mixin render%) [dest-dir work-dir])] - [docs (list (dynamic-require src-file 'doc))] - [fns (list (build-path work-dir dest-file))] - [fp (send renderer traverse docs fns)] - [info (send renderer collect docs fns fp)] - [r-info (send renderer resolve docs fns info)]) - (send renderer render docs fns r-info) - (send renderer get-undefined r-info))) + (define renderer (new (markdown:render-mixin render%) [dest-dir work-dir])) + (define docs (list (dynamic-require src-file 'doc))) + (define fns (list (build-path work-dir dest-file))) + (define fp (send renderer traverse docs fns)) + (define info (send renderer collect docs fns fp)) + (define r-info (send renderer resolve docs fns info)) + (send renderer render docs fns r-info) + (send renderer get-undefined r-info)) (provide markdown-tests) (module+ main (markdown-tests)) @@ -40,11 +40,9 @@ (define (contents file) (regexp-replace #rx"\n+$" (file->string file) "")) (define undefineds (build-markdown-doc src-file "gen.md")) - (for ([u (in-list undefineds)]) - (when (eq? 'tech (car u)) - (test #:failure-message - (format "undefined tech: ~e" u) - #f))) + (for ([u (in-list undefineds)] + #:when (eq? 'tech (car u))) + (test #:failure-message (format "undefined tech: ~e" u) #f)) (test #:failure-message (format "mismatch for: \"~a\", expected text in: \"~a\", got:\n~a" diff --git a/scribble-test/tests/scribble/reader.rkt b/scribble-test/tests/scribble/reader.rkt index 1fa756db15..ed0627b692 100644 --- a/scribble-test/tests/scribble/reader.rkt +++ b/scribble-test/tests/scribble/reader.rkt @@ -947,14 +947,14 @@ END-OF-TESTS (define m (or (regexp-match #px"^(.*)\n\\s*(-\\S+->)\\s*\n(.*)$" t) (regexp-match #px"^(.*\\S)\\s+(-\\S+->)\\s+(\\S.*)$" t))) - (if (not (and m (= 4 (length m)))) - (error 'bad-test "~a" t) - (let-values ([(x y) ((string->tester (caddr m)) (cadr m) (cadddr m))]) - (test #:failure-message (format "bad result in\n ~a\n results:\n ~s != ~s" - (regexp-replace* #rx"\n" t "\n ") - x - y) - (matching? x y))))))) + (unless (and m (= 4 (length m))) + (error 'bad-test "~a" t)) + (let-values ([(x y) ((string->tester (caddr m)) (cadr m) (cadddr m))]) + (test #:failure-message (format "bad result in\n ~a\n results:\n ~s != ~s" + (regexp-replace* #rx"\n" t "\n ") + x + y) + (matching? x y)))))) ;; Check static versus dynamic readtable for command (dynamic when "c" in the ;; name) and datum (dynamic when "d" in the name) parts: diff --git a/scribble-test/tests/scribble/text-lang.rkt b/scribble-test/tests/scribble/text-lang.rkt index 364821b279..1f886cb469 100644 --- a/scribble-test/tests/scribble/text-lang.rkt +++ b/scribble-test/tests/scribble/text-lang.rkt @@ -67,4 +67,4 @@ (call-with-trusted-sandbox-configuration (lambda () (for ([t (in-list (doc:tests))]) - (begin (apply text-test t)))))) + (apply text-test t))))) diff --git a/scribble-text-lib/scribble/text/output.rkt b/scribble-text-lib/scribble/text/output.rkt index 027034b023..d2480f4034 100644 --- a/scribble-text-lib/scribble/text/output.rkt +++ b/scribble-text-lib/scribble/text/output.rkt @@ -112,11 +112,12 @@ (cond [(pair? nls) (define nl (car nls)) - (if (regexp-match? #rx"^ *$" x start (car nl)) - (newline p) ; only spaces before the end of the line - (begin - (output-pfx col pfx lpfx) - (write x p start (cdr nl)))) + (cond + [(regexp-match? #rx"^ *$" x start (car nl)) + (newline p)] ; only spaces before the end of the line + [else + (output-pfx col pfx lpfx) + (write x p start (cdr nl))]) (loop (cdr nl) (cdr nls) 0 0)] ;; last substring from here (always set lpfx state when done) [(start . = . len) (set-mcdr! pfxs lpfx)] @@ -279,10 +280,7 @@ [(eq? p (car last)) (cdr last)] [else (define s - (or (hash-ref t p #f) - (let ([s (mcons 0 0)]) - (hash-set! t p s) - s))) + (hash-ref! t p (λ () (mcons 0 0)))) (set! last (cons p s)) s])))) diff --git a/scribble-text-lib/scribble/text/syntax-utils.rkt b/scribble-text-lib/scribble/text/syntax-utils.rkt index 0577c13783..955ff8c1f7 100644 --- a/scribble-text-lib/scribble/text/syntax-utils.rkt +++ b/scribble-text-lib/scribble/text/syntax-utils.rkt @@ -145,23 +145,24 @@ (loop (append (syntax->list #'(x ...)) (cdr exprs)) ds es)] [(define-syntaxes (id ...) rhs) (andmap identifier? (syntax->list #'(id ...))) - (if (null? es) - (let ([ids (syntax->list #'(id ...))]) - (syntax-local-bind-syntaxes ids - (local-transformer-expand #'rhs 'expression '()) - (car ctx)) - (loop (cdr exprs) (cons (rebuild-bindings) ds) es)) - ;; return the unexpanded expr, to be re-expanded later, in the - ;; right contexts - (values (reverse ds) (reverse es) exprs))] + (cond + [(null? es) + (define ids (syntax->list #'(id ...))) + (syntax-local-bind-syntaxes ids + (local-transformer-expand #'rhs 'expression '()) + (car ctx)) + (loop (cdr exprs) (cons (rebuild-bindings) ds) es)] + ;; return the unexpanded expr, to be re-expanded later, in the + ;; right contexts + [else (values (reverse ds) (reverse es) exprs)])] [(define-values (id ...) rhs) (andmap identifier? (syntax->list #'(id ...))) - (if (null? es) - (begin - (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f (car ctx)) - (loop (cdr exprs) (cons (rebuild-bindings) ds) es)) - ;; same note here - (values (reverse ds) (reverse es) exprs))] + (cond + [(null? es) + (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f (car ctx)) + (loop (cdr exprs) (cons (rebuild-bindings) ds) es)] + ;; same note here + [else (values (reverse ds) (reverse es) exprs)])] [_ (loop (cdr exprs) ds (cons expr* es))])]))) (define-syntax (begin/collect* stx) ; helper, has a boolean flag first (define-values [exprs always-list?]