diff --git a/scribble-lib/scribble/acmart.rkt b/scribble-lib/scribble/acmart.rkt index 1df5231199..f75a79e489 100644 --- a/scribble-lib/scribble/acmart.rkt +++ b/scribble-lib/scribble/acmart.rkt @@ -28,68 +28,55 @@ #:name author-institution #:transparent) -(provide/contract - [title (->* () - (#:short pre-content? - #:tag (or/c string? (listof string?) #f) - #:tag-prefix (or/c string? module-path? #f) - #:style (or/c style? string? symbol? #f) - #:version (or/c string? #f) - #:date (or/c string? #f)) - #:rest (listof pre-content?) - title-decl?)] - [author (->* () - (#:orcid (or/c pre-content? #f) - #:affiliation (or/c pre-content? - affiliation? - (listof affiliation?) - #f) - #: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?)] - [institution (->* () - (#:departments (listof (or/c pre-content? institution?))) - #:rest pre-content? - institution?)] - [institution? (-> any/c boolean?)] - [email (-> pre-content? ... email?)] - [email-string (-> string? ... email?)] - [email? (-> any/c boolean?)] - [affiliation (->* () - (#:position (or/c pre-content? #f) - #:institution (or/c pre-content? institution? (listof institution?) #f) - #:street-address (or/c pre-content? #f) - #:city (or/c pre-content? #f) - #:state (or/c pre-content? #f) - #:postcode (or/c pre-content? #f) - #:country (or/c pre-content? #f)) - affiliation?)] - [affiliation? (-> any/c boolean?)] - [abstract - (->* () () #:rest (listof pre-content?) - block?)] - [acmConference - (-> string? string? string? block?)] - [grantsponsor - (-> string? string? string? content?)] - [grantnum - (->* (string? string?) (#:url string?) content?)] - [acmBadgeR (->* (string?) (#:url string?) block?)] - [acmBadgeL (->* (string?) (#:url string?) block?)] - [received (->* (string?) (#:stage string?) block?)] - [citestyle (-> content? block?)] - [ccsdesc (->* (string?) (#:number exact-integer?) block?)] - [CCSXML - (->* () () #:rest (listof pre-content?) - any/c)]) +(provide (contract-out [title + (->* () + (#:short pre-content? + #:tag (or/c string? (listof string?) #f) + #:tag-prefix (or/c string? module-path? #f) + #:style (or/c style? string? symbol? #f) + #:version (or/c string? #f) + #:date (or/c string? #f)) + #:rest (listof pre-content?) + title-decl?)] + [author + (->* () + (#:orcid (or/c pre-content? #f) + #:affiliation (or/c pre-content? affiliation? (listof affiliation?) #f) + #: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?)] + [institution + (->* () + (#:departments (listof (or/c pre-content? institution?))) + #:rest pre-content? + institution?)] + [institution? (-> any/c boolean?)] + [email (-> pre-content? ... email?)] + [email-string (-> string? ... email?)] + [email? (-> any/c boolean?)] + [affiliation + (->* () + (#:position (or/c pre-content? #f) + #:institution (or/c pre-content? institution? (listof institution?) #f) + #:street-address (or/c pre-content? #f) + #:city (or/c pre-content? #f) + #:state (or/c pre-content? #f) + #:postcode (or/c pre-content? #f) + #:country (or/c pre-content? #f)) + affiliation?)] + [affiliation? (-> any/c boolean?)] + [abstract (->* () () #:rest (listof pre-content?) block?)] + [acmConference (-> string? string? string? block?)] + [grantsponsor (-> string? string? string? content?)] + [grantnum (->* (string? string?) (#:url string?) content?)] + [acmBadgeR (->* (string?) (#:url string?) block?)] + [acmBadgeL (->* (string?) (#:url string?) block?)] + [received (->* (string?) (#:stage string?) block?)] + [citestyle (-> content? block?)] + [ccsdesc (->* (string?) (#:number exact-integer?) block?)] + [CCSXML (->* () () #:rest (listof pre-content?) any/c)])) (provide invisible-element-to-collect-for-acmart-extras include-abstract) @@ -335,7 +322,7 @@ (decode-content name))] [else (make-element (make-style "department" (append - (if (> level 0) + (if (positive? level) (list (command-optional (list (number->string level)))) (list)) command-props)) diff --git a/scribble-lib/scribble/bnf.rkt b/scribble-lib/scribble/bnf.rkt index 72d72e0e23..e1d6c5371e 100644 --- a/scribble-lib/scribble/bnf.rkt +++ b/scribble-lib/scribble/bnf.rkt @@ -64,9 +64,8 @@ [(cons lhs (cons rhs0 more-rhs)) (cons (list (as-flow spacer) (as-flow lhs) (as-flow equals) (as-flow rhs0)) - (map (lambda (i) - (list (as-flow spacer) (as-flow " ") (as-flow alt) (as-flow i))) - more-rhs))]) + (for/list ([i (in-list more-rhs)]) + (list (as-flow spacer) (as-flow " ") (as-flow alt) (as-flow i))))]) defns)))) ;; interleave : (listof content?) element? -> element? diff --git a/scribble-lib/scribble/eval.rkt b/scribble-lib/scribble/eval.rkt index f68344e357..34d156a90c 100644 --- a/scribble-lib/scribble/eval.rkt +++ b/scribble-lib/scribble/eval.rkt @@ -166,15 +166,13 @@ (define val-list (cadar promptless?+val-list+outputs)) (if (equal? val-list (list (void))) null - (map (lambda (v) - (list.flow.list - (make-paragraph (list (if (formatted-result? v) - (formatted-result-content v) - (elem #:style result-color - (to-element/no-color - v - #:expr? (print-as-expression)))))))) - val-list))]) + (for/list ([v (in-list val-list)]) + (list.flow.list + (make-paragraph + (list (if (formatted-result? v) + (formatted-result-content v) + (elem #:style result-color + (to-element/no-color v #:expr? (print-as-expression)))))))))]) (if (and (caar promptless?+val-list+outputs) (pair? (cdr promptless?+val-list+outputs))) (list (list (list blank-line))) @@ -381,10 +379,10 @@ (vector-set! v2 i (loop (vector-ref v i)))) v2)] [(box? v) - (let ([v2 (box #f)]) - (hash-set! ht v v2) - (set-box! v2 (loop (unbox v))) - v2)] + (define v2 (box #f)) + (hash-set! ht v v2) + (set-box! v2 (loop (unbox v))) + v2] [(hash? v) (define ph (make-placeholder #f)) (hash-set! ht v ph) @@ -469,12 +467,12 @@ (define base-factory (apply make-base-eval-factory mod-paths #:lang lang #:pretty-print? pretty-print? ips)) (lambda () - (let ([ev (base-factory)]) - (call-in-sandbox-context ev - (lambda () - (for ([mod-path (in-list mod-paths)]) - (namespace-require mod-path)))) - ev))) + (define ev (base-factory)) + (call-in-sandbox-context ev + (lambda () + (for ([mod-path (in-list mod-paths)]) + (namespace-require mod-path)))) + ev)) (define (make-log-based-eval logfile mode) (case mode @@ -494,39 +492,38 @@ (lambda () ;; Required for serialization to work. (namespace-attach-module (namespace-anchor->namespace anchor) 'racket/serialize) - (let ([old-eval (current-eval)] - [init-out-p (current-output-port)] - [init-err-p (current-error-port)] - [out-p (open-output-bytes)] - [err-p (open-output-bytes)]) - (current-eval - (lambda (x) - (let* ([x (syntax->datum (datum->syntax #f x))] - [x (if (and (pair? x) (eq? (car x) '#%top-interaction)) - (cdr x) - x)] - [result (with-handlers ([exn? values]) - (call-with-values (lambda () - (parameterize ([current-eval old-eval] - [current-custodian (make-custodian)] - [current-output-port out-p] - [current-error-port err-p]) - (begin0 (old-eval x) - (wait-for-threads (current-custodian) - super-cust)))) - list))] - [out-s (get-output-bytes out-p #t)] - [err-s (get-output-bytes err-p #t)]) - (let ([result* (serialize (cond - [(list? result) (cons 'values result)] - [(exn? result) (list 'exn (exn-message result))]))]) - (pretty-write (list x result* out-s err-s) out) - (flush-output out)) - (display out-s init-out-p) - (display err-s init-err-p) - (cond - [(list? result) (apply values result)] - [(exn? result) (raise result)]))))))) + (define old-eval (current-eval)) + (define init-out-p (current-output-port)) + (define init-err-p (current-error-port)) + (define out-p (open-output-bytes)) + (define err-p (open-output-bytes)) + (current-eval + (lambda (x) + (let* ([x (syntax->datum (datum->syntax #f x))] + [x (if (and (pair? x) (eq? (car x) '#%top-interaction)) + (cdr x) + x)] + [result (with-handlers ([exn? values]) + (call-with-values (lambda () + (parameterize ([current-eval old-eval] + [current-custodian (make-custodian)] + [current-output-port out-p] + [current-error-port err-p]) + (begin0 (old-eval x) + (wait-for-threads (current-custodian) super-cust)))) + list))] + [out-s (get-output-bytes out-p #t)] + [err-s (get-output-bytes err-p #t)]) + (let ([result* (serialize (cond + [(list? result) (cons 'values result)] + [(exn? result) (list 'exn (exn-message result))]))]) + (pretty-write (list x result* out-s err-s) out) + (flush-output out)) + (display out-s init-out-p) + (display err-s init-err-p) + (cond + [(list? result) (apply values result)] + [(exn? result) (raise result)])))))) ev) ;; Wait for threads created by evaluation so that the evaluator catches output @@ -536,19 +533,19 @@ (define give-up-evt (alarm-evt (+ (current-inexact-milliseconds) 200.0))) ;; find a thread to wait on (define (find-thread cust) - (let* ([managed (custodian-managed-list cust super-cust)] - [thds (filter thread? managed)] - [custs (filter custodian? managed)]) - (cond - [(pair? thds) (car thds)] - [else (ormap find-thread custs)]))) + (define managed (custodian-managed-list cust super-cust)) + (define thds (filter thread? managed)) + (define custs (filter custodian? managed)) + (cond + [(pair? thds) (car thds)] + [else (ormap find-thread custs)])) ;; keep waiting on threads (one at a time) until time to give up (define (wait-loop cust) - (let ([thd (find-thread cust)]) - (when thd - (cond - [(eq? give-up-evt (sync thd give-up-evt)) (void)] - [else (wait-loop cust)])))) + (define thd (find-thread cust)) + (when thd + (cond + [(eq? give-up-evt (sync thd give-up-evt)) (void)] + [else (wait-loop cust)]))) (wait-loop sub-cust)) (define (make-eval/replay logfile) @@ -558,37 +555,37 @@ ev (lambda () (namespace-attach-module (namespace-anchor->namespace anchor) 'racket/serialize) - (let ([old-eval (current-eval)] - [init-out-p (current-output-port)] - [init-err-p (current-error-port)]) - (current-eval - (lambda (x) - (let* ([x (syntax->datum (datum->syntax #f x))] - [x (if (and (pair? x) (eq? (car x) '#%top-interaction)) - (cdr x) - x)]) - (unless (and (pair? evaluations) (equal? x (car (car evaluations)))) - ;; TODO: smarter resync - ;; - can handle *additions* by removing next set! - ;; - can handle *deletions* by searching forward (but may jump to far - ;; if terms occur more than once, eg for stateful code) - ;; For now, just fail early and often. - (set! evaluations null) - (error 'eval "unable to replay evaluation of ~.s" x)) - (let* ([evaluation (car evaluations)] - [result (parameterize ([current-eval old-eval]) - (deserialize (cadr evaluation)))] - [result (case (car result) - [(values) (cdr result)] - [(exn) (make-exn (cadr result) (current-continuation-marks))])] - [output (caddr evaluation)] - [error-output (cadddr evaluation)]) - (set! evaluations (cdr evaluations)) - (display output init-out-p #| (current-output-port) |#) - (display error-output init-err-p #| (current-error-port) |#) - (cond - [(exn? result) (raise result)] - [(list? result) (apply values result)])))))))) + (define old-eval (current-eval)) + (define init-out-p (current-output-port)) + (define init-err-p (current-error-port)) + (current-eval + (lambda (x) + (let* ([x (syntax->datum (datum->syntax #f x))] + [x (if (and (pair? x) (eq? (car x) '#%top-interaction)) + (cdr x) + x)]) + (unless (and (pair? evaluations) (equal? x (car (car evaluations)))) + ;; TODO: smarter resync + ;; - can handle *additions* by removing next set! + ;; - can handle *deletions* by searching forward (but may jump to far + ;; if terms occur more than once, eg for stateful code) + ;; For now, just fail early and often. + (set! evaluations null) + (error 'eval "unable to replay evaluation of ~.s" x)) + (let* ([evaluation (car evaluations)] + [result (parameterize ([current-eval old-eval]) + (deserialize (cadr evaluation)))] + [result (case (car result) + [(values) (cdr result)] + [(exn) (make-exn (cadr result) (current-continuation-marks))])] + [output (caddr evaluation)] + [error-output (cadddr evaluation)]) + (set! evaluations (cdr evaluations)) + (display output init-out-p #| (current-output-port) |#) + (display error-output init-err-p #| (current-error-port) |#) + (cond + [(exn? result) (raise result)] + [(list? result) (apply values result)]))))))) ev) (define (close-eval e) @@ -647,29 +644,27 @@ ;; Also preserve syntax-original?, since that seems important ;; to some syntax-based code (eg redex term->pict). (define (get-source-location e) - (let* ([src (build-source-location-list e)] - [old-source (source-location-source src)] - [new-source - (cond [(path? old-source) ;; not quotable/writable - ;;(path->string old-source) ;; don't leak build paths - 'eval] - [(or (string? old-source) - (symbol? old-source)) - ;; Okay? Or should this be replaced also? - old-source] - [else #f])]) - (update-source-location src #:source new-source))) + (define src (build-source-location-list e)) + (define old-source (source-location-source src)) + (define new-source + (cond + ;; not quotable/writable + ;;(path->string old-source) ;; don't leak build paths + [(path? old-source) 'eval] + ;; Okay? Or should this be replaced also? + [(or (string? old-source) (symbol? old-source)) old-source] + [else #f])) + (update-source-location src #:source new-source)) (let loop ([e #'e]) (cond [(syntax? e) - (let ([src (get-source-location e)] - [original? (syntax-original? (syntax-local-introduce e))]) - #`(syntax-property - (datum->syntax #f - #,(loop (syntax-e e)) - (quote #,src) - #,(if original? #'orig-stx #'#f)) - 'paren-shape - (quote #,(syntax-property e 'paren-shape))))] + (define src (get-source-location e)) + (define original? (syntax-original? (syntax-local-introduce e))) + #`(syntax-property (datum->syntax #f + #,(loop (syntax-e e)) + (quote #,src) + #,(if original? #'orig-stx #'#f)) + 'paren-shape + (quote #,(syntax-property e 'paren-shape)))] [(pair? e) #`(cons #,(loop (car e)) #,(loop (cdr e)))] [(vector? e) @@ -865,15 +860,11 @@ [(_ racketblock e ...) (racketblockX+eval racketblock #:eval (make-base-eval) #:escape unsyntax e ...)])) -(define-syntax racketblock+eval - (syntax-rules () - [(_ e ...) - (racketblockX+eval racketblock e ...)])) +(define-syntax-rule (racketblock+eval e ...) + (racketblockX+eval racketblock e ...)) -(define-syntax racketblock0+eval - (syntax-rules () - [(_ e ...) - (racketblockX+eval racketblock0 e ...)])) +(define-syntax-rule (racketblock0+eval e ...) + (racketblockX+eval racketblock0 e ...)) (define-syntax racketmod+eval (syntax-rules () @@ -958,7 +949,7 @@ (define (do-splice l) (cond [(null? l) null] - [(splice? (car l)) `(,@(splice-run (car l)) ,@(do-splice (cdr l)))] + [(splice? (car l)) (append (splice-run (car l)) (do-splice (cdr l)))] [else (cons (car l) (do-splice (cdr l)))])) (define as-examples diff --git a/scribble-lib/scribble/search.rkt b/scribble-lib/scribble/search.rkt index aa41892ee4..44cc07961d 100644 --- a/scribble-lib/scribble/search.rkt +++ b/scribble-lib/scribble/search.rkt @@ -93,10 +93,11 @@ (list* (module-path-index->taglet mod) id (if suffix (list suffix) null))) - (when (not search-key) - (set! search-key (if unlinked-ok? - (cons #f eb) - eb))) + (unless search-key + (set! search-key + (if unlinked-ok? + (cons #f eb) + eb))) (define v (and eb (resolve-search search-key part ri `(dep ,eb)))) (define here-result (and need-result? @@ -164,37 +165,35 @@ (hash-set! module-info-cache rmp t) t))) (hash-set! seen (cons export-phase rmp) #t) - (let ([a (assq id (let ([a (assoc export-phase exports)]) - (if a - (cdr a) - null)))]) - (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))) - rqueue) - need-result?)] - [else - ;; A dead end may not be our fault: the files could - ;; have changed in inconsistent ways. So just say #f - ;; for now. - #; - (error 'find-racket-tag - "dead end when looking for binding source: ~e" - id) - (loop queue rqueue need-result?)]))] + (define a + (assq id + (let ([a (assoc export-phase exports)]) + (if a + (cdr a) + null)))) + (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))) + rqueue) + need-result?)] + ;; A dead end may not be our fault: the files could + ;; have changed in inconsistent ways. So just say #f + ;; for now. + #;(error 'find-racket-tag "dead end when looking for binding source: ~e" id) + [else (loop queue rqueue need-result?)])] [else ;; Can't get the module source, so continue with queue: (loop queue rqueue need-result?)])) diff --git a/scribble-lib/scribble/srcdoc.rkt b/scribble-lib/scribble/srcdoc.rkt index 8a8d306da4..7143a61cc1 100644 --- a/scribble-lib/scribble/srcdoc.rkt +++ b/scribble-lib/scribble/srcdoc.rkt @@ -74,18 +74,15 @@ (syntax-local-introduce (syntax-shift-phase-level s #f))) (with-syntax ([((req ...) ...) - (map (lambda (rs) - (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))) - (reverse requires))] + (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)))] [(expr ...) (map shift-and-introduce (reverse doc-exprs))] [doc-body @@ -124,30 +121,19 @@ (define-for-syntax (do-provide/doc stx modes) (let ([forms (list stx)]) (with-syntax ([((for-provide/contract (req ...) d id) ...) - (map (lambda (form) - (syntax-case form () - [(id . _) - (identifier? #'id) - (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)))))] - [_ - (raise-syntax-error - #f - "not a provide/doc sub-form" - stx - form)])) - forms)]) + (for/list ([form (in-list forms)]) + (syntax-case form () + [(id . _) + (identifier? #'id) + (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)))))] + [_ (raise-syntax-error #f "not a provide/doc sub-form" stx form)]))]) (with-syntax ([(p/c ...) (map (lambda (form f) (if (identifier? f) diff --git a/scribble-lib/scribble/struct.rkt b/scribble-lib/scribble/struct.rkt index a5b38f12d6..e28a3a7d59 100644 --- a/scribble-lib/scribble/struct.rkt +++ b/scribble-lib/scribble/struct.rkt @@ -386,9 +386,9 @@ (let ([sn (assq 'style row)] [a (assq 'alignment row)] [va (assq 'valignment row)]) - (if (or sn a va) - (gen-columns sn a va) - (error 'convert-style "no row style found"))))))]))))] + (unless (or sn a va) + (error 'convert-style "no row style found")) + (gen-columns sn a va)))))]))))] [else (error 'convert-style "unrecognized style: ~e" s)])) (define (flatten-style s)