diff --git a/scribble-lib/scribble/markdown-render.rkt b/scribble-lib/scribble/markdown-render.rkt index 18bb48ef1e..625d2d697f 100644 --- a/scribble-lib/scribble/markdown-render.rkt +++ b/scribble-lib/scribble/markdown-render.rkt @@ -104,26 +104,24 @@ (displayln "```")] [else - (define strs (map (lambda (flows) - (map (lambda (d) - (cond - [(eq? d 'cont) d] - [else - (define o (open-output-string)) - (parameterize ([current-indent 0] - [current-output-port o]) - (render-block d part ht #f)) - (regexp-split - #rx"\n" - (regexp-replace #rx"\n$" (get-output-string o) ""))])) - flows)) - flowss)) - (define widths (map (lambda (col) - (for/fold ([d 0]) ([i (in-list col)]) - (if (eq? i 'cont) - 0 - (apply max d (map string-length i))))) - (apply map list strs))) + (define strs (for/list ([flows (in-list flowss)]) + (map + (lambda (d) + (cond + [(eq? d 'cont) d] + [else + (define o (open-output-string)) + (parameterize ([current-indent 0] + [current-output-port o]) + (render-block d part ht #f)) + (regexp-split #rx"\n" + (regexp-replace #rx"\n$" (get-output-string o) ""))])) + flows))) + (define widths (for/list ([col (in-list (apply map list strs))]) + (for/fold ([d 0]) ([i (in-list col)]) + (if (eq? i 'cont) + 0 + (apply max d (map string-length i)))))) (define (x-length col) (if (eq? col 'cont) 0 (length col))) (for/fold ([indent? #f]) ([row (in-list strs)]) diff --git a/scribble-lib/scribble/render.rkt b/scribble-lib/scribble/render.rkt index 5be87c8be5..9bfdb197df 100644 --- a/scribble-lib/scribble/render.rkt +++ b/scribble-lib/scribble/render.rkt @@ -69,24 +69,24 @@ (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) diff --git a/scribble-lib/scribble/search.rkt b/scribble-lib/scribble/search.rkt index 44cc07961d..cd0078487a 100644 --- a/scribble-lib/scribble/search.rkt +++ b/scribble-lib/scribble/search.rkt @@ -174,19 +174,18 @@ (cond [a (loop queue - (append (map (lambda (m) - (if (pair? m) - (list (module-path-index-rejoin (car m) mod) - (list-ref m 2) - defn-phase - (list-ref m 1) - (list-ref m 3)) - (list (module-path-index-rejoin m mod) - id - defn-phase - import-phase - export-phase))) - (reverse (cadr a))) + (append (for/list ([m (in-list (reverse (cadr a)))]) + (if (pair? m) + (list (module-path-index-rejoin (car m) mod) + (list-ref m 2) + defn-phase + (list-ref m 1) + (list-ref m 3)) + (list (module-path-index-rejoin m mod) + id + defn-phase + import-phase + export-phase))) rqueue) need-result?)] ;; A dead end may not be our fault: the files could diff --git a/scribble-lib/scribble/srcdoc.rkt b/scribble-lib/scribble/srcdoc.rkt index 7143a61cc1..a599355e05 100644 --- a/scribble-lib/scribble/srcdoc.rkt +++ b/scribble-lib/scribble/srcdoc.rkt @@ -75,14 +75,13 @@ (syntax-shift-phase-level s #f))) (with-syntax ([((req ...) ...) (for/list ([rs (in-list (reverse requires))]) - (map (lambda (r) - (syntax-case r () - [(op arg ...) - (with-syntax ([(arg ...) (map shift-and-introduce - (syntax->list #'(arg ...)))]) - #'(op arg ...))] - [else (shift-and-introduce r)])) - (syntax->list rs)))] + (for/list ([r (in-list (syntax->list rs))]) + (syntax-case r () + [(op arg ...) + (with-syntax ([(arg ...) (map shift-and-introduce + (syntax->list #'(arg ...)))]) + #'(op arg ...))] + [else (shift-and-introduce r)])))] [(expr ...) (map shift-and-introduce (reverse doc-exprs))] [doc-body @@ -128,11 +127,12 @@ (let ([t (syntax-local-value #'id (lambda () #f))]) (unless (provide/doc-transformer? t) (raise-syntax-error #f "not bound as a provide/doc transformer" stx #'id)) - (let* ([i (make-syntax-introducer)] - [i2 (lambda (x) (syntax-local-introduce (i x)))]) - (let-values ([(p/c d req/d id) ((provide/doc-transformer-proc t) - (i (syntax-local-introduce form)))]) - (list (i2 p/c) (i req/d) (i d) (i id)))))] + (define i (make-syntax-introducer)) + (define (i2 x) + (syntax-local-introduce (i x))) + (let-values ([(p/c d req/d id) ((provide/doc-transformer-proc t) + (i (syntax-local-introduce form)))]) + (list (i2 p/c) (i req/d) (i d) (i id))))] [_ (raise-syntax-error #f "not a provide/doc sub-form" stx form)]))]) (with-syntax ([(p/c ...) (map (lambda (form f) @@ -345,44 +345,52 @@ (let ([build-mandatories/optionals (λ (names contracts extras) - (let ([names-length (length names)] - [contracts-length (length contracts)]) - (let loop ([contracts contracts] - [names names] - [extras extras]) - (cond - [(and (null? names) (null? contracts)) '()] - [(or (null? names) (null? contracts)) - (raise-syntax-error #f - (format "mismatched ~a argument list count and domain contract count (~a)" - (if extras "optional" "mandatory") - (if (null? names) - "ran out of names" - "ran out of contracts")) - stx)] - [else - (let ([fst-name (car names)] - [fst-ctc (car contracts)]) - (if (keyword? (syntax-e fst-ctc)) - (begin - (unless (pair? (cdr contracts)) - (raise-syntax-error #f - "keyword not followed by a contract" - stx)) - (cons (if extras - (list fst-ctc fst-name (cadr contracts) (car extras)) - (list fst-ctc fst-name (cadr contracts))) - (loop (cddr contracts) - (cdr names) - (if extras - (cdr extras) - extras)))) - (cons (if extras - (list fst-name fst-ctc (car extras)) - (list fst-name fst-ctc)) - (loop (cdr contracts) (cdr names) (if extras - (cdr extras) - extras)))))]))))]) + (length names) + (length contracts) + (let loop ([contracts contracts] + [names names] + [extras extras]) + (cond + [(and (null? names) (null? contracts)) '()] + [(or (null? names) (null? contracts)) + (raise-syntax-error + #f + (format + "mismatched ~a argument list count and domain contract count (~a)" + (if extras "optional" "mandatory") + (if (null? names) + "ran out of names" + "ran out of contracts")) + stx)] + [else + (let ([fst-name (car names)] + [fst-ctc (car contracts)]) + (if (keyword? (syntax-e fst-ctc)) + (begin + (unless (pair? (cdr contracts)) + (raise-syntax-error + #f + "keyword not followed by a contract" + stx)) + (cons (if extras + (list fst-ctc + fst-name + (cadr contracts) + (car extras)) + (list fst-ctc fst-name (cadr contracts))) + (loop (cddr contracts) + (cdr names) + (if extras + (cdr extras) + extras)))) + (cons (if extras + (list fst-name fst-ctc (car extras)) + (list fst-name fst-ctc)) + (loop (cdr contracts) + (cdr names) + (if extras + (cdr extras) + extras)))))])))]) #`([(id #,@(build-mandatories/optionals (syntax->list #'(mandatory-names ...)) (syntax->list #'(mandatory ...)) @@ -404,19 +412,22 @@ [((x y) ...) (andmap identifier? (syntax->list #'(x ... y ...)))] [((x y) ...) - (for-each - (λ (var) - (unless (identifier? var) - (raise-syntax-error #f "expected an identifier in the optional names" stx var))) - (syntax->list #'(x ... y ...)))] + (for ([var (in-list (syntax->list #'(x ... y ...)))]) + (unless (identifier? var) + (raise-syntax-error + #f + "expected an identifier in the optional names" + stx + var)))] [(a ...) - (for-each - (λ (a) - (syntax-case stx () - [(x y) (void)] - [other - (raise-syntax-error #f "expected an sequence of two idenfiers" stx #'other)])) - (syntax->list #'(a ...)))]))] + (for ([a (in-list (syntax->list #'(a ...)))]) + (syntax-case stx () + [(x y) (void)] + [other + (raise-syntax-error #f + "expected an sequence of two idenfiers" + stx + #'other)]))]))] [x (raise-syntax-error #f @@ -492,12 +503,9 @@ "expected an identifier or sequence of two identifiers" stx #'struct-name)]) - (for ([f (in-list (syntax->list #'(field-name ...)))]) - (unless (identifier? f) - (raise-syntax-error #f - "expected an identifier" - stx - f))) + (for ([f (in-list (syntax->list #'(field-name ...)))] + #:unless (identifier? f)) + (raise-syntax-error #f "expected an identifier" stx f)) (define omit-constructor? #f) (define-values (ds-args desc) (let loop ([ds-args '()] diff --git a/scribble-lib/scribble/tag.rkt b/scribble-lib/scribble/tag.rkt index fa9e861715..abd89dda5f 100644 --- a/scribble-lib/scribble/tag.rkt +++ b/scribble-lib/scribble/tag.rkt @@ -51,38 +51,41 @@ (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))] + (cond + [b + (or (weak-box-value b) + ;; just in case the value is GCed before we extract it: + (intern-taglet v))] + [else + (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: (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)))) + (cond + [(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. + (define rp (resolved-module-path-name (module-path-index-resolve mod))) + (if (path? rp) + (intern-taglet (path->collects-relative rp)) + rp)] + [else + (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) diff --git a/scribble-lib/scribble/xref.rkt b/scribble-lib/scribble/xref.rkt index 5177196e83..60858b4a1d 100644 --- a/scribble-lib/scribble/xref.rkt +++ b/scribble-lib/scribble/xref.rkt @@ -55,29 +55,37 @@ (let* ([renderer (new render% [dest-dir (find-system-path 'temp-dir)])] [fp (send renderer traverse null null)] [load-source (lambda (src ci) - (parameterize ([current-namespace - (namespace-anchor->empty-namespace here)]) - (let ([vs (src)]) - (for ([v (in-list (if (procedure? vs) (vs) (list vs)))]) - (when v - (define data (if (data+root? v) (data+root-data v) v)) - (define root (if (data+root? v) (data+root-root v) root-path)) - (define doc-id (or (and (data+root+doc-id? v) (data+root+doc-id-doc-id v)) - doc-id-str)) - (define pkg (or (and (data+root+doc-id+pkg? v) (data+root+doc-id+pkg-pkg v)) - pkg-str)) - (send renderer deserialize-info data ci - #:root root - #:doc-id doc-id - #:pkg pkg))))))] + (parameterize ([current-namespace (namespace-anchor->empty-namespace here)]) + (define vs (src)) + (for ([v (in-list (if (procedure? vs) + (vs) + (list vs)))]) + (when v + (define data + (if (data+root? v) + (data+root-data v) + v)) + (define root + (if (data+root? v) + (data+root-root v) + root-path)) + (define doc-id + (or (and (data+root+doc-id? v) (data+root+doc-id-doc-id v)) + doc-id-str)) + (define pkg + (or (and (data+root+doc-id+pkg? v) (data+root+doc-id+pkg-pkg v)) + pkg-str)) + (send renderer deserialize-info + data + ci + #:root root + #:doc-id doc-id + #:pkg pkg)))))] [use-ids (make-weak-hasheq)] [ci (send renderer collect null null fp (lambda (key ci) (define use-obj (collect-info-ext-ht ci)) - (define use-id (or (hash-ref use-ids use-obj #f) - (let ([s (gensym 'render)]) - (hash-set! use-ids use-obj s) - s))) + (define use-id (hash-ref! use-ids use-obj (λ () (gensym 'render)))) (define src (demand-source-for-use key use-id)) (and src (load-source src ci))))]) @@ -117,58 +125,46 @@ [_ (send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))] [ri (send renderer resolve (list doc) (list dest-file) ci)] [xs (send renderer render (list doc) (list dest-file) ri)]) - (if dest-file - (void) - (car xs)))) + (unless dest-file + (car xs)))) (define (xref-transfer-info renderer ci xrefs) (send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))) ;; Returns (values ) -(define (xref-binding-tag xrefs id/binding mode - #:space [space #f] - #:suffix [suffix space]) - (let ([search - (lambda (id/binding) - (let ([tag (find-scheme-tag #f (xrefs-ri xrefs) id/binding mode - #:space space - #:suffix suffix)]) - (if tag - (values tag (eq? (car tag) 'form)) - (values #f #f))))]) - (cond - [(identifier? id/binding) - (search id/binding)] - [(and (list? id/binding) - (= 7 (length id/binding))) - (search id/binding)] - [(and (list? id/binding) - (= 2 (length id/binding))) - (let loop ([src (car id/binding)]) - (cond - [(module-path-index? src) - (search (list src (cadr id/binding)))] - [(module-path? src) - (loop (module-path-index-join src #f))] - [else - (raise-argument-error 'xref-binding-definition->tag - "(list/c (or/c module-path? module-path-index?) any/c)" - id/binding)]))] - [else (raise-argument-error 'xref-binding-definition->tag - (string-append - "(or/c identifier? (lambda (l)\n" - " (and (list? l)\n" - " (or (= (length l) 2)\n" - " (= (length l) 7)))))") - id/binding)]))) - -(define (xref-binding->definition-tag xrefs id/binding mode +(define (xref-binding-tag xrefs id/binding mode #:space [space #f] #:suffix [suffix space]) + (define (search id/binding) + (let ([tag (find-scheme-tag #f (xrefs-ri xrefs) id/binding mode #:space space #:suffix suffix)]) + (if tag + (values tag (eq? (car tag) 'form)) + (values #f #f)))) + (cond + [(identifier? id/binding) (search id/binding)] + [(and (list? id/binding) (= 7 (length id/binding))) (search id/binding)] + [(and (list? id/binding) (= 2 (length id/binding))) + (let loop ([src (car id/binding)]) + (cond + [(module-path-index? src) (search (list src (cadr id/binding)))] + [(module-path? src) (loop (module-path-index-join src #f))] + [else + (raise-argument-error 'xref-binding-definition->tag + "(list/c (or/c module-path? module-path-index?) any/c)" + id/binding)]))] + [else + (raise-argument-error 'xref-binding-definition->tag + (string-append "(or/c identifier? (lambda (l)\n" + " (and (list? l)\n" + " (or (= (length l) 2)\n" + " (= (length l) 7)))))") + id/binding)])) + +(define (xref-binding->definition-tag xrefs + id/binding + mode #:space [space #f] #:suffix [suffix space]) - (let-values ([(tag form?) (xref-binding-tag xrefs id/binding mode - #:space space - #:suffix suffix)]) - tag)) + (define-values (tag form?) (xref-binding-tag xrefs id/binding mode #:space space #:suffix suffix)) + tag) (define (xref-tag->path+anchor xrefs tag #:render% [render% (html:render-mixin render%)] @@ -180,15 +176,13 @@ tag->path+anchor (xrefs-ri xrefs) tag)) (define (xref-tag->index-entry xrefs tag) - (let ([v (hash-ref - (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs))) - `(index-entry ,tag) - #f)]) - (let ([v (if (known-doc? v) - (known-doc-v v) - v)]) - (cond [v (make-entry (car v) (cadr v) (cadr tag) (caddr v))] - [(and (pair? tag) (eq? 'form (car tag))) - ;; Try again with 'def: - (xref-tag->index-entry xrefs (cons 'def (cdr tag)))] - [else #f])))) + (define v + (hash-ref (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs))) `(index-entry ,tag) #f)) + (let ([v (if (known-doc? v) + (known-doc-v v) + v)]) + (cond + [v (make-entry (car v) (cadr v) (cadr tag) (caddr v))] + ;; Try again with 'def: + [(and (pair? tag) (eq? 'form (car tag))) (xref-tag->index-entry xrefs (cons 'def (cdr tag)))] + [else #f])))