diff --git a/scribble-lib/scribble/base-render.rkt b/scribble-lib/scribble/base-render.rkt index 2c63b679e9..760657912c 100644 --- a/scribble-lib/scribble/base-render.rkt +++ b/scribble-lib/scribble/base-render.rkt @@ -83,30 +83,25 @@ (not (ormap number? number)))) null] [else + (define s + (string-append (apply string-append + (map (lambda (n) + (cond + [(number? n) (format "~a." n)] + [(or (not n) (string? n)) ""] + [(pair? n) (string-append (car n) (cadr n))])) + (reverse (cdr number)))) + (if (and (car number) (not (equal? "" (car number)))) + (if (pair? (car number)) + (if keep-separator? + (string-append (caar number) (cadar number)) + (caar number)) + (format "~a." (car number))) + ""))) (define result-s - (let ([s (string-append - (apply - string-append - (map (lambda (n) - (cond - [(number? n) (format "~a." n)] - [(or (not n) (string? n)) ""] - [(pair? n) (string-append (car n) (cadr n))])) - (reverse (cdr number)))) - (if (and (car number) - (not (equal? "" (car number)))) - (if (pair? (car number)) - (if keep-separator? - (string-append (caar number) - (cadar number)) - (caar number)) - (format "~a." (car number))) - ""))]) - (if (or keep-separator? - (pair? (car number)) - (equal? s "")) - s - (substring s 0 (sub1 (string-length s)))))) + (if (or keep-separator? (pair? (car number)) (equal? s "")) + s + (substring s 0 (sub1 (string-length s))))) (if (equal? result-s "") null (cons result-s sep))])) @@ -162,9 +157,9 @@ (extract-content-style-files (part-title-content p) d ri ht pred extract) (extract-flow-style-files (part-blocks p) d ri ht pred extract)) (unless only-up? - (for ([p (in-list (part-parts p))]) - (unless (stop-at-part? p) - (loop p #f #f))))) + (for ([p (in-list (part-parts p))] + #:unless (stop-at-part? p)) + (loop p #f #f)))) (map cdr (sort (for/list ([(k v) (in-hash ht)]) (cons v (if (or (bytes? k) (url? k)) k (collects-relative->path k)))) @@ -172,9 +167,9 @@ #:key car))) (define/private (extract-style-style-files s ht pred extract) - (for ([v (in-list (style-properties s))]) - (when (pred v) - (hash-update! ht (extract v) values (hash-count ht))))) + (for ([v (in-list (style-properties s))] + #:when (pred v)) + (hash-update! ht (extract v) values (hash-count ht)))) (define/private (extract-flow-style-files blocks d ri ht pred extract) (for ([b (in-list blocks)]) @@ -185,9 +180,9 @@ [(table? p) (extract-style-style-files (table-style p) ht pred extract) (for* ([blocks (in-list (table-blockss p))] - [block (in-list blocks)]) - (unless (eq? block 'cont) - (extract-block-style-files block d ri ht pred extract)))] + [block (in-list blocks)] + #:unless (eq? block 'cont)) + (extract-block-style-files block d ri ht pred extract))] [(itemization? p) (extract-style-style-files (itemization-style p) ht pred extract) (for-each (lambda (blocks) (extract-flow-style-files blocks d ri ht pred extract)) @@ -247,8 +242,7 @@ (let loop ([l (part-blocks d)]) (apply append (for/list ([b (in-list l)]) - (define lifted (lift-proc b loop)) - lifted)))) + (lift-proc b loop))))) (define/private (extract-pre-paras-proc sym) (λ (v loop) @@ -346,34 +340,37 @@ (define/private (partition-info all-ci n d) ;; partition information in `all-ci' based on `d's: - (let ([prefix (part-tag-prefix-string d)] - [new-hts (for/list ([i (in-range n)]) - (make-hash))] - [covered (make-hash)]) - ;; Fill in new-hts from parts: - (for ([sub-d (in-list (part-parts d))] - [i (in-naturals)]) - (define ht (list-ref new-hts (min (add1 i) (sub1 n)))) - (define cdi (hash-ref (collect-info-parts all-ci) sub-d #f)) - (define sub-prefix (part-tag-prefix-string sub-d)) - (when cdi - (for ([(k v) (in-hash (collected-info-info cdi))]) - (when (cadr k) - (define sub-k (if sub-prefix - (convert-key sub-prefix k) - k)) - (define full-k (if prefix - (convert-key prefix sub-k) - sub-k)) - (hash-set! ht full-k v) - (hash-set! covered full-k #t))))) - ;; Anything not covered in the new-hts must go in the main hts: - (let ([ht0 (car new-hts)]) - (for ([(k v) (in-hash (collect-info-ht all-ci))]) - (unless (hash-ref covered k #f) - (hash-set! ht0 k v)))) - ;; Return hts: - new-hts)) + (define prefix (part-tag-prefix-string d)) + (define new-hts + (for/list ([i (in-range n)]) + (make-hash))) + (define covered (make-hash)) + ;; Fill in new-hts from parts: + (for ([sub-d (in-list (part-parts d))] + [i (in-naturals)]) + (define ht (list-ref new-hts (min (add1 i) (sub1 n)))) + (define cdi (hash-ref (collect-info-parts all-ci) sub-d #f)) + (define sub-prefix (part-tag-prefix-string sub-d)) + (when cdi + (for ([(k v) (in-hash (collected-info-info cdi))]) + (when (cadr k) + (define sub-k + (if sub-prefix + (convert-key sub-prefix k) + k)) + (define full-k + (if prefix + (convert-key prefix sub-k) + sub-k)) + (hash-set! ht full-k v) + (hash-set! covered full-k #t))))) + ;; Anything not covered in the new-hts must go in the main hts: + (let ([ht0 (car new-hts)]) + (for ([(k v) (in-hash (collect-info-ht all-ci))]) + (unless (hash-ref covered k #f) + (hash-set! ht0 k v)))) + ;; Return hts: + new-hts) (define/public (serialize-info ri) (serialize-one-ht ri (collect-info-ht (resolve-info-ci ri)))) @@ -396,11 +393,11 @@ (hash-set! in-ht k (if (or doc-id pkg) (known-doc v doc-id pkg) v)))) (define/public (get-defined ci) - (hash-map (collect-info-ht ci) (lambda (k v) k))) + (hash-keys (collect-info-ht ci))) (define/public (get-defineds ci n d) (for/list ([ht (partition-info ci n d)]) - (hash-map ht (lambda (k v) k)))) + (hash-keys ht))) (define/public (get-external ri) (hash-map (resolve-info-undef ri) (lambda (k v) k))) diff --git a/scribble-lib/scribble/render.rkt b/scribble-lib/scribble/render.rkt index 5be87c8be5..9b263fb4fb 100644 --- a/scribble-lib/scribble/render.rkt +++ b/scribble-lib/scribble/render.rkt @@ -69,28 +69,28 @@ (unless quiet? (send renderer report-output!)) (define fns - (map (lambda (fn) - (let-values ([(base name dir?) (split-path fn)]) - (let ([fn (path-replace-suffix name (send renderer get-suffix))]) - (if dest-dir - (build-path dest-dir fn) - fn)))) - names)) + (for/list ([fn (in-list names)]) + (define-values (base name dir?) (split-path fn)) + (let ([fn (path-replace-suffix name (send renderer get-suffix))]) + (if dest-dir + (build-path dest-dir fn) + fn)))) (define fp (send renderer traverse docs fns)) (define info (send renderer collect docs fns fp)) (for ([file (in-list info-input-files)]) - (let ([s (with-input-from-file file read)]) (send renderer deserialize-info s info))) + (define s (with-input-from-file file read)) + (send renderer deserialize-info s info)) (for ([xr (in-list xrefs)]) (xref-transfer-info renderer info xr)) (let ([r-info (send renderer resolve docs fns info)]) (send renderer render docs fns r-info) (when info-output-file - (let ([s (send renderer serialize-info r-info)]) - (with-output-to-file info-output-file #:exists 'truncate/replace (lambda () (write s))))) + (define s (send renderer serialize-info r-info)) + (with-output-to-file info-output-file #:exists 'truncate/replace (lambda () (write s)))) (when warn-undefined? - (let ([undef (send renderer get-undefined r-info)]) - (unless (null? undef) - (eprintf "Warning: some cross references may be broken due to undefined tags:\n") - (for ([t (in-list undef)]) - (eprintf " ~s\n" t)))))) + (define undef (send renderer get-undefined r-info)) + (unless (null? undef) + (eprintf "Warning: some cross references may be broken due to undefined tags:\n") + (for ([t (in-list undef)]) + (eprintf " ~s\n" t))))) (void)) diff --git a/scribble-lib/scribble/tag.rkt b/scribble-lib/scribble/tag.rkt index 3d2c4eef8c..fa9e861715 100644 --- a/scribble-lib/scribble/tag.rkt +++ b/scribble-lib/scribble/tag.rkt @@ -48,58 +48,45 @@ (let ([v (if (list? v) (map intern-taglet v) (datum-intern-literal v))]) - (if (or (string? v) - (bytes? v) - (list? v)) - (let ([b (hash-ref interned v #f)]) - (if b - (or (weak-box-value b) - ;; just in case the value is GCed before we extract it: - (intern-taglet v)) - (begin - (hash-set! interned v (make-weak-box v)) - v))) - v))) + (cond + [(or (string? v) (bytes? v) (list? v)) + (define b (hash-ref interned v #f)) + (if b + (or (weak-box-value b) + ;; just in case the value is GCed before we extract it: + (intern-taglet v)) + (begin + (hash-set! interned v (make-weak-box v)) + v))] + [else v]))) (define (do-module-path-index->taglet mod) ;; Derive the name from the module path: - (let ([p (collapse-module-path-index - mod - (lambda () (build-path (current-directory) "dummy")))]) - (if (path? p) - ;; If we got a path back anyway, then it's best to use the resolved - ;; name; if the current directory has changed since we - ;; the path-index was resolved, then p might not be right. Also, - ;; the resolved path might be a symbol instead of a path. - (let ([rp (resolved-module-path-name - (module-path-index-resolve mod))]) - (if (path? rp) - (intern-taglet - (path->collects-relative rp)) - rp)) - (let ([p (if (and (pair? p) - (eq? (car p) 'planet)) - ;; Normalize planet verion number based on current - ;; linking: - (let-values ([(path pkg) - (get-planet-module-path/pkg p #f #f)]) - (list* 'planet - (cadr p) - (list (car (caddr p)) - (cadr (caddr p)) - (pkg-maj pkg) - (pkg-min pkg)) - (cdddr p))) - ;; Otherwise the path is fully normalized: - p)]) - (intern-taglet p))))) + (define p (collapse-module-path-index mod (lambda () (build-path (current-directory) "dummy")))) + (if (path? p) + ;; If we got a path back anyway, then it's best to use the resolved + ;; name; if the current directory has changed since we + ;; the path-index was resolved, then p might not be right. Also, + ;; the resolved path might be a symbol instead of a path. + (let ([rp (resolved-module-path-name (module-path-index-resolve mod))]) + (if (path? rp) + (intern-taglet (path->collects-relative rp)) + rp)) + (let ([p (if (and (pair? p) (eq? (car p) 'planet)) + ;; Normalize planet verion number based on current + ;; linking: + (let-values ([(path pkg) (get-planet-module-path/pkg p #f #f)]) + (list* 'planet + (cadr p) + (list (car (caddr p)) (cadr (caddr p)) (pkg-maj pkg) (pkg-min pkg)) + (cdddr p))) + ;; Otherwise the path is fully normalized: + p)]) + (intern-taglet p)))) (define collapsed (make-weak-hasheq)) (define (module-path-index->taglet mod) - (or (hash-ref collapsed mod #f) - (let ([v (do-module-path-index->taglet mod)]) - (hash-set! collapsed mod v) - v))) + (hash-ref! collapsed mod (λ () (do-module-path-index->taglet mod)))) (define (module-path-prefix->string p) (datum-intern-literal @@ -123,9 +110,8 @@ (define (definition-tag->class/interface-tag t) (cons 'class/intf (cdr t))) (define (class/interface-tag->constructor-tag t) (cons 'constructor (cdr t))) (define (get-class/interface-and-method meth-tag) - (match meth-tag - [`(meth ((,_ ,class/interface) ,method)) - (values class/interface method)])) + (match-define `(meth ((,_ ,class/interface) ,method)) meth-tag) + (values class/interface method)) (define (definition-tag? x) (and (tag? x) (equal? (car x) 'def))) (define (class/interface-tag? x) (and (tag? x) (equal? (car x) 'class/intf))) (define (method-tag? x) (and (tag? x) (equal? (car x) 'meth))) 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)))))