diff --git a/scribble-lib/scribble/acmart.rkt b/scribble-lib/scribble/acmart.rkt index f75a79e489..5955f428b8 100644 --- a/scribble-lib/scribble/acmart.rkt +++ b/scribble-lib/scribble/acmart.rkt @@ -45,8 +45,8 @@ #:email (or/c pre-content? email? (listof email?))) #:rest (listof pre-content?) block?)] - [authorsaddresses (->* () () #:rest (listof pre-content?) block?)] - [shortauthors (->* () () #:rest (listof pre-content?) element?)] + [authorsaddresses (-> pre-content? ... block?)] + [shortauthors (-> pre-content? ... element?)] [institution (->* () (#:departments (listof (or/c pre-content? institution?))) @@ -67,7 +67,7 @@ #:country (or/c pre-content? #f)) affiliation?)] [affiliation? (-> any/c boolean?)] - [abstract (->* () () #:rest (listof pre-content?) block?)] + [abstract (-> pre-content? ... block?)] [acmConference (-> string? string? string? block?)] [grantsponsor (-> string? string? string? content?)] [grantnum (->* (string? string?) (#:url string?) content?)] @@ -76,7 +76,7 @@ [received (->* (string?) (#:stage string?) block?)] [citestyle (-> content? block?)] [ccsdesc (->* (string?) (#:number exact-integer?) block?)] - [CCSXML (->* () () #:rest (listof pre-content?) any/c)])) + [CCSXML (-> pre-content? ... any/c)])) (provide invisible-element-to-collect-for-acmart-extras include-abstract) diff --git a/scribble-lib/scribble/sigplan.rkt b/scribble-lib/scribble/sigplan.rkt index d57ed2d5a6..420a2b9518 100644 --- a/scribble-lib/scribble/sigplan.rkt +++ b/scribble-lib/scribble/sigplan.rkt @@ -8,44 +8,19 @@ scribble/latex-properties (for-syntax racket/base)) -(provide/contract - [abstract - (->* () () #:rest (listof pre-content?) - block?)] - [subtitle - (->* () () #:rest (listof pre-content?) - content?)] - [authorinfo - (-> pre-content? pre-content? pre-content? - block?)] - [conferenceinfo - (-> pre-content? pre-content? - block?)] - [copyrightyear - (->* () () #:rest (listof pre-content?) - block?)] - [copyrightdata - (->* () () #:rest (listof pre-content?) - block?)] - [exclusive-license - (->* () () - block?)] - [doi - (->* () () #:rest (listof pre-content?) - block?)] - [to-appear - (->* () () #:rest pre-content? - block?)] - [category - (->* (pre-content? pre-content? pre-content?) - ((or/c #f pre-content?)) - content?)] - [terms - (->* () () #:rest (listof pre-content?) - content?)] - [keywords - (->* () () #:rest (listof pre-content?) - content?)]) +(provide (contract-out + [abstract (->* () () #:rest (listof pre-content?) block?)] + [subtitle (->* () () #:rest (listof pre-content?) content?)] + [authorinfo (-> pre-content? pre-content? pre-content? block?)] + [conferenceinfo (-> pre-content? pre-content? block?)] + [copyrightyear (->* () () #:rest (listof pre-content?) block?)] + [copyrightdata (->* () () #:rest (listof pre-content?) block?)] + [exclusive-license (->* () () block?)] + [doi (->* () () #:rest (listof pre-content?) block?)] + [to-appear (->* () () #:rest pre-content? block?)] + [category (->* (pre-content? pre-content? pre-content?) ((or/c #f pre-content?)) content?)] + [terms (->* () () #:rest (listof pre-content?) content?)] + [keywords (->* () () #:rest (listof pre-content?) content?)])) (provide preprint 10pt nocopyright onecolumn noqcourier notimes include-abstract) diff --git a/scribble-lib/scribble/srcdoc.rkt b/scribble-lib/scribble/srcdoc.rkt index 7143a61cc1..8120aef65b 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)))))]))))]) + (define names-length (length names)) + (define 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)))))])))]) #`([(id #,@(build-mandatories/optionals (syntax->list #'(mandatory-names ...)) (syntax->list #'(mandatory ...)) @@ -404,11 +412,13 @@ [((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) 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]))) diff --git a/scribble-test/tests/scribble/reader.rkt b/scribble-test/tests/scribble/reader.rkt index ed0627b692..ca7afa903a 100644 --- a/scribble-test/tests/scribble/reader.rkt +++ b/scribble-test/tests/scribble/reader.rkt @@ -847,9 +847,9 @@ END-OF-TESTS (values (read-all x inside-reader #t) (read-all y read))) (define (x . (mk-eval-test syntax-reader) . y) - (define r (void)) - (for ([x (read-all x (lambda (i) (syntax-reader 'test i)))]) - (set! r (call-with-values (lambda () (eval x ns)) list))) + (define r + (for/fold ([r (void)]) ([x (read-all x (lambda (i) (syntax-reader 'test i)))]) + (call-with-values (lambda () (eval x ns)) list))) (values r (read-all y read))) (define (x . (mk-syntax-test syntax-reader) . y) @@ -949,12 +949,12 @@ END-OF-TESTS (regexp-match #px"^(.*\\S)\\s+(-\\S+->)\\s+(\\S.*)$" t))) (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)))))) + (define-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-text-lib/scribble/text/output.rkt b/scribble-text-lib/scribble/text/output.rkt index d2480f4034..d72a65f439 100644 --- a/scribble-text-lib/scribble/text/output.rkt +++ b/scribble-text-lib/scribble/text/output.rkt @@ -57,11 +57,14 @@ 0)) ;; combines a prefix with a target column to get to (define (pfx+col pfx) - (and pfx (let ([col (getcol)]) - (cond [(number? pfx) (max pfx col)] - [(>= (string-length pfx) col) pfx] - [else (string-append - pfx (make-spaces (- col (string-length pfx))))])))) + (cond + [pfx + (define col (getcol)) + (cond + [(number? pfx) (max pfx col)] + [(>= (string-length pfx) col) pfx] + [else (string-append pfx (make-spaces (- col (string-length pfx))))])] + [else #f])) ;; adds two prefixes (define (pfx+ pfx1 pfx2) (and pfx1 pfx2