diff --git a/scribble-lib/scribble/private/indirect-renderer.rkt b/scribble-lib/scribble/private/indirect-renderer.rkt index 68371ecfd4..509067c097 100644 --- a/scribble-lib/scribble/private/indirect-renderer.rkt +++ b/scribble-lib/scribble/private/indirect-renderer.rkt @@ -19,19 +19,14 @@ (define/override (get-suffix) target-suffix) (define/override (render srcs dests ri) (define tmp-dir - (make-temporary-file - (format "scribble-~a-to-~a-~~a" - (dotless base-suffix) (dotless target-suffix)) - 'directory)) + (make-temporary-directory + (format "scribble-~a-to-~a-~~a" (dotless base-suffix) (dotless target-suffix)))) (define (cleanup) (when (directory-exists? tmp-dir) (delete-directory/files tmp-dir))) (with-handlers ([void (lambda (e) (cleanup) (raise e))]) (define tmp-dests - (map (lambda (dest) - (build-path tmp-dir - (path-replace-suffix (file-name-from-path dest) - base-suffix))) - dests)) + (for/list ([dest (in-list dests)]) + (build-path tmp-dir (path-replace-suffix (file-name-from-path dest) base-suffix)))) (set! tmp-dest-dir tmp-dir) ;; it would be better if it's ok to change current-directory for this (super render srcs tmp-dests ri) diff --git a/scribble-lib/scribble/private/manual-bib.rkt b/scribble-lib/scribble/private/manual-bib.rkt index d7694520cf..db0b3aa839 100644 --- a/scribble-lib/scribble/private/manual-bib.rkt +++ b/scribble-lib/scribble/private/manual-bib.rkt @@ -65,7 +65,9 @@ `(" " ,@(decode-content (list location)) ,(if date "," ".")) null) (if date `(" " ,@(decode-content (list date)) ".") null) - (if url `(" " ,(link url (tt url))) null) + (if url (list " " + (link url + (tt url))) null) (if note (decode-content (list note)) null))))) (define-on-demand bib-style (make-style "RBibliography" scheme-properties)) diff --git a/scribble-lib/scribble/private/manual-bind.rkt b/scribble-lib/scribble/private/manual-bind.rkt index fb8b9962df..58cba2d134 100644 --- a/scribble-lib/scribble/private/manual-bind.rkt +++ b/scribble-lib/scribble/private/manual-bind.rkt @@ -59,10 +59,7 @@ (define hovers (make-weak-hasheq)) (define (intern-hover-style text) (let ([text (datum-intern-literal text)]) - (or (hash-ref hovers text #f) - (let ([s (make-style #f (list (make-hover-property text)))]) - (hash-set! hovers text s) - s)))) + (hash-ref! hovers text (λ () (make-style #f (list (make-hover-property text))))))) (define (annote-exporting-library e) (make-delayed-element @@ -71,15 +68,14 @@ (if (and from (pair? from)) (make-element (intern-hover-style - (string-append - "Provided from: " - (string-join (map ~s from) ", ") - (let ([from-pkgs (resolve-get/tentative p ri '(exporting-packages #f))]) - (if (and from-pkgs (pair? from-pkgs)) - (string-append - " | Package: " - (string-join (map ~a from-pkgs) ", ")) - "")))) + (string-join (map ~s from) + ", " + #:before-first "Provided from: " + #:after-last + (let ([from-pkgs (resolve-get/tentative p ri '(exporting-packages #f))]) + (if (and from-pkgs (pair? from-pkgs)) + (string-append " | Package: " (string-join (map ~a from-pkgs) ", ")) + "")))) e) e)) (lambda () e) @@ -114,30 +110,30 @@ (lambda (x add) x))) (let ([lib (or (for/or ([lib (in-list (or source-libs null))]) - (let ([checker - (hash-ref - checkers lib - (lambda () - (define ns-id - (let ([ns (make-base-empty-namespace)]) - (parameterize ([current-namespace ns]) - ;; A `(namespace-require `(for-label ,lib))` can - ;; fail if `lib` provides different bindings of the - ;; same name at different phases. We can require phases - ;; 1 and 0 separately, in which case the phase-0 - ;; binding shadows the phase-1 one in that case. - ;; This strategy only works for documenting bindings - ;; at phases 0 and 1, though. - (namespace-require `(just-meta 1 (for-label ,lib))) - (namespace-require `(just-meta 0 (for-label ,lib))) - (namespace-syntax-introduce (datum->syntax #f 'x))))) - (define (checker id intro) - (free-label-identifier=? - (intro (datum->syntax ns-id (syntax-e id)) 'add) - (intro id 'add))) - (hash-set! checkers lib checker) - checker))]) - (and (checker id intro) lib))) + (define checker + (hash-ref checkers + lib + (lambda () + (define ns-id + (let ([ns (make-base-empty-namespace)]) + (parameterize ([current-namespace ns]) + ;; A `(namespace-require `(for-label ,lib))` can + ;; fail if `lib` provides different bindings of the + ;; same name at different phases. We can require phases + ;; 1 and 0 separately, in which case the phase-0 + ;; binding shadows the phase-1 one in that case. + ;; This strategy only works for documenting bindings + ;; at phases 0 and 1, though. + (namespace-require `(just-meta 1 (for-label ,lib))) + (namespace-require `(just-meta 0 (for-label ,lib))) + (namespace-syntax-introduce (datum->syntax #f 'x))))) + (define (checker id intro) + (free-label-identifier=? (intro (datum->syntax ns-id (syntax-e id)) + 'add) + (intro id 'add))) + (hash-set! checkers lib checker) + checker))) + (and (checker id intro) lib)) (and (pair? libs) (car libs)))]) (and lib (module-path-index->taglet (module-path-index-join lib #f))))) @@ -198,79 +194,64 @@ #:show-libs? [show-libs? #t]) ;; This function could have more optional argument to select ;; whether to index the id, include a toc link, etc. - (let ([dep? #t]) - (define maker - (if form? - (id-to-form-target-maker id dep?) - (id-to-target-maker id dep?))) - (define-values (elem elem-ref) - (if show-libs? - (definition-site (syntax-e id) id form?) - (values (to-element id #:defn? #t) - (to-element id)))) - (if maker - (maker elem - (lambda (tag) - (let ([elem - (if index? - (make-index-element - #f (list elem) tag - (list (datum-intern-literal (symbol->string (syntax-e id)))) - (list elem) - (and show-libs? - (with-exporting-libraries - (lambda (libs) - (make-exported-index-desc (syntax-e id) - libs))))) - elem)]) - (make-target-element #f (list elem) tag)))) - elem))) + (define dep? #t) + (define maker + (if form? + (id-to-form-target-maker id dep?) + (id-to-target-maker id dep?))) + (define-values (elem elem-ref) + (if show-libs? + (definition-site (syntax-e id) id form?) + (values (to-element id #:defn? #t) (to-element id)))) + (if maker + (maker elem + (lambda (tag) + (let ([elem (if index? + (make-index-element + #f + (list elem) + tag + (list (datum-intern-literal (symbol->string (syntax-e id)))) + (list elem) + (and show-libs? + (with-exporting-libraries + (lambda (libs) (make-exported-index-desc (syntax-e id) libs))))) + elem)]) + (make-target-element #f (list elem) tag)))) + elem)) (define (make-binding-redirect-elements mod-path redirects) (define taglet (module-path-index->taglet (module-path-index-join mod-path #f))) (make-element #f - (map - (lambda (redirect) - (define id (car redirect)) - (define form? (cadr redirect)) - (define path (caddr redirect)) - (define anchor (cadddr redirect)) - (define (make-one kind) - (make-redirect-target-element - #f - null - (intern-taglet (list kind (list taglet id))) - path - anchor)) - (make-element - #f - (list (make-one (if form? 'form 'def)) - (make-dep (list taglet id) null) - (let ([str (datum-intern-literal (symbol->string id))]) - (make-index-element #f - null - (intern-taglet - (list (if form? 'form 'def) - (list taglet id))) - (list str) - (list - (make-element - symbol-color - (list - (make-element - (if form? - syntax-link-color - value-link-color) - (list str))))) - (make-exported-index-desc* - id - (list mod-path) - (hash 'kind (if form? - "syntax" - "procedure")))))))) - redirects))) + (for/list ([redirect (in-list redirects)]) + (define id (car redirect)) + (define form? (cadr redirect)) + (define path (caddr redirect)) + (define anchor (cadddr redirect)) + (define (make-one kind) + (make-redirect-target-element #f + null + (intern-taglet (list kind (list taglet id))) + path + anchor)) + (make-element + #f + (list (make-one (if form? 'form 'def)) + (make-dep (list taglet id) null) + (let ([str (datum-intern-literal (symbol->string id))]) + (make-index-element + #f + null + (intern-taglet (list (if form? 'form 'def) (list taglet id))) + (list str) + (list (make-element symbol-color + (list (make-element (if form? syntax-link-color value-link-color) + (list str))))) + (make-exported-index-desc* id + (list mod-path) + (hash 'kind (if form? "syntax" "procedure")))))))))) (define (make-dep t content) diff --git a/scribble-lib/scribble/private/manual-class.rkt b/scribble-lib/scribble/private/manual-class.rkt index 7cff96cfe0..bcbeeac2ef 100644 --- a/scribble-lib/scribble/private/manual-class.rkt +++ b/scribble-lib/scribble/private/manual-class.rkt @@ -48,14 +48,9 @@ (define (id-info id) (define b (identifier-label-binding id)) - (if b - (list (caddr b) - (list-ref b 3) - (list-ref b 4) - (list-ref b 5) - (list-ref b 6)) - (error 'scribble "no class/interface/mixin information for identifier: ~e" - id))) + (unless b + (error 'scribble "no class/interface/mixin information for identifier: ~e" id)) + (list (caddr b) (list-ref b 3) (list-ref b 4) (list-ref b 5) (list-ref b 6))) (define (make-inherited-table r d ri decl) (define start @@ -155,11 +150,11 @@ null)) (define (build-body decl body) - `(,@(map (lambda (i) - (cond [(constructor? i) ((constructor-def i))] - [(meth? i) ((meth-def i))] - [else i])) - body) + `(,@(for/list ([i (in-list body)]) + (cond + [(constructor? i) ((constructor-def i))] + [(meth? i) ((meth-def i))] + [else i])) ,(make-delayed-block (lambda (r d ri) (make-inherited-table r d ri decl))))) (define (*include-class/title decl link?) diff --git a/scribble-lib/scribble/private/manual-style.rkt b/scribble-lib/scribble/private/manual-style.rkt index a4b855628e..62824b791d 100644 --- a/scribble-lib/scribble/private/manual-style.rkt +++ b/scribble-lib/scribble/private/manual-style.rkt @@ -22,10 +22,11 @@ itemize aux-elem code-inset) -(provide/contract [filebox (((or/c core:element? string?)) () #:rest (listof pre-flow?) . ->* . block?)]) +(provide (contract-out + [filebox (((or/c core:element? string?)) () #:rest (listof pre-flow?) . ->* . block?)])) (define styling-f/c - (() () #:rest (listof pre-content?) . ->* . element?)) + (-> pre-content? ... element?)) (define-syntax-rule (provide-styling id ...) (provide/contract [id styling-f/c] ...)) (provide-styling racketmodfont racketoutput @@ -53,35 +54,32 @@ (provide void-const undefined-const) -(provide/contract - [PLaneT element?] - [hash-lang (-> element?)] - [etc element?] - [inset-flow (() () #:rest (listof pre-content?) . ->* . nested-flow?)] - [litchar (() () #:rest (listof string?) . ->* . element?)] - [t (() () #:rest (listof pre-content?) . ->* . paragraph?)] - [exec (() () #:rest (listof content?) . ->* . element?)] - [commandline (() () #:rest (listof content?) . ->* . paragraph?)] - [menuitem (string? string? . -> . element?)]) +(provide (contract-out [PLaneT element?] + [hash-lang (-> element?)] + [etc element?] + [inset-flow (() () #:rest (listof pre-content?) . ->* . nested-flow?)] + [litchar (() () #:rest (listof string?) . ->* . element?)] + [t (() () #:rest (listof pre-content?) . ->* . paragraph?)] + [exec (() () #:rest (listof content?) . ->* . element?)] + [commandline (() () #:rest (listof content?) . ->* . paragraph?)] + [menuitem (string? string? . -> . element?)])) (define PLaneT (make-element "planetName" '("PLaneT"))) (define etc (make-element #f (list "etc" ._))) (define (litchar . strs) - (let ([s (string-append* (map (lambda (s) (regexp-replace* "\n" s " ")) - strs))]) - (cond - [(regexp-match? #rx"^ *$" s) (make-element input-background-color (list (hspace (string-length s))))] - [else - (define ^spaces (car (regexp-match-positions #rx"^ *" s))) - (define $spaces (car (regexp-match-positions #rx" *$" s))) - (make-element - input-background-color - (list (hspace (cdr ^spaces)) - (make-element input-color - (list (substring s (cdr ^spaces) (car $spaces)))) - (hspace (- (cdr $spaces) (car $spaces)))))]))) + (define s (string-append* (map (lambda (s) (regexp-replace* "\n" s " ")) strs))) + (cond + [(regexp-match? #rx"^ *$" s) + (make-element input-background-color (list (hspace (string-length s))))] + [else + (define ^spaces (car (regexp-match-positions #rx"^ *" s))) + (define $spaces (car (regexp-match-positions #rx" *$" s))) + (make-element input-background-color + (list (hspace (cdr ^spaces)) + (make-element input-color (list (substring s (cdr ^spaces) (car $spaces)))) + (hspace (- (cdr $spaces) (car $spaces)))))])) (define (onscreen . str) (make-element 'sf (decode-content str))) @@ -173,11 +171,10 @@ (make-blockquote code-inset-style (list b))) (define (commandline . s) - (make-paragraph (cons (hspace 2) (map (lambda (s) - (if (string? s) - (make-element 'tt (list s)) - s)) - s)))) + (make-paragraph (cons (hspace 2) (for/list ([s (in-list s)]) + (if (string? s) + (make-element 'tt (list s)) + s))))) (define (pidefterm . s) (define c (apply defterm s)) diff --git a/scribble-lib/scriblib/footnote.rkt b/scribble-lib/scriblib/footnote.rkt index c40ad6972f..8da1d229dc 100644 --- a/scribble-lib/scriblib/footnote.rkt +++ b/scribble-lib/scriblib/footnote.rkt @@ -44,27 +44,19 @@ (define (footnote-part . text) (do-footnote-part footnotes id)))) (define (do-footnote footnotes id text) - (let ([tag (generated-tag)] - [content (decode-content text)]) - (make-traverse-element - (lambda (get set) - (set id (cons (cons - (make-element footnote-target-style - (make-element - 'superscript - (counter-target footnotes tag #f))) + (define tag (generated-tag)) + (define content (decode-content text)) + (make-traverse-element + (lambda (get set) + (set id + (cons (cons (make-element footnote-target-style + (make-element 'superscript (counter-target footnotes tag #f))) content) - (get id null))) - (make-element footnote-style - (list - (make-element - footnote-ref-style - (make-element - 'superscript - (counter-ref footnotes tag #f))) - (make-element - footnote-content-style - content))))))) + (get id null))) + (make-element footnote-style + (list (make-element footnote-ref-style + (make-element 'superscript (counter-ref footnotes tag #f))) + (make-element footnote-content-style content)))))) (define (do-footnote-part footnotes id) (make-part @@ -78,9 +70,6 @@ (lambda (get set) (make-compound-paragraph footnote-block-style - (map (lambda (content) - (make-paragraph - footnote-block-content-style - content)) - (reverse (get id null))))))) + (for/list ([content (in-list (reverse (get id null)))]) + (make-paragraph footnote-block-content-style content)))))) null)) diff --git a/scribble-lib/scriblib/gui-eval.rkt b/scribble-lib/scriblib/gui-eval.rkt index 69b3ee3576..1bd6567aaf 100644 --- a/scribble-lib/scriblib/gui-eval.rkt +++ b/scribble-lib/scriblib/gui-eval.rkt @@ -12,28 +12,26 @@ racket/sandbox (for-syntax racket/base)) -(define-syntax define-mr - (syntax-rules () - [(_ mr orig) - (begin - (provide mr) - (define-syntax (mr stx) - (syntax-case stx () - [(_ #:eval+opts the-eval get-predicate? get-render get-get-width get-get-height x (... ...)) - #'(let ([the-eval-x the-eval]) - (parameterize ([scribble-eval-handler (gui-eval-handler the-eval-x - get-predicate? - get-render - get-get-width - get-get-height)]) - (orig #:eval the-eval-x x (... ...))))] - [(_ x (... ...)) - #'(parameterize ([scribble-eval-handler (gui-eval-handler gui-eval - (λ () (gui-eval 'pict?)) - (λ () (gui-eval 'draw-pict)) - (λ () (gui-eval 'pict-width)) - (λ () (gui-eval 'pict-height)))]) - (orig #:eval gui-eval x (... ...)))])))])) +(define-syntax-rule (define-mr mr orig) + (begin + (provide mr) + (define-syntax (mr stx) + (syntax-case stx () + [(_ #:eval+opts the-eval get-predicate? get-render get-get-width get-get-height x (... ...)) + #'(let ([the-eval-x the-eval]) + (parameterize ([scribble-eval-handler (gui-eval-handler the-eval-x + get-predicate? + get-render + get-get-width + get-get-height)]) + (orig #:eval the-eval-x x (... ...))))] + [(_ x (... ...)) + #'(parameterize ([scribble-eval-handler (gui-eval-handler gui-eval + (λ () (gui-eval 'pict?)) + (λ () (gui-eval 'draw-pict)) + (λ () (gui-eval 'pict-width)) + (λ () (gui-eval 'pict-height)))]) + (orig #:eval gui-eval x (... ...)))])))) (define gui-eval (make-base-eval #:pretty-print? #f)) @@ -68,61 +66,63 @@ "exprs.dat")) (define gui-eval-handler - (if mred? - (let ([eh (scribble-eval-handler)] - [log-file (open-output-file exprs-dat-file #:exists 'truncate/replace)]) - (λ (gui-eval get-predicate? get-render get-get-width get-get-height) - (lambda (ev catching-exns? expr) - (write (serialize (if (syntax? expr) (syntax->datum expr) expr)) log-file) - (newline log-file) - (flush-output log-file) - (let ([result - (with-handlers ([exn:fail? - (lambda (exn) - (make-gui-exn (exn-message exn)))]) - ;; put the call to fixup-picts in the handlers - ;; so that errors in the user-supplied predicates & - ;; conversion functions show up in the rendered output - (fixup-picts (get-predicate?) (get-render) (get-get-width) (get-get-height) - (eh ev catching-exns? expr)))]) - (write (serialize result) log-file) - (newline log-file) - (flush-output log-file) - (if (gui-exn? result) - (raise (make-exn:fail - (gui-exn-message result) - (current-continuation-marks))) - result))))) - (let ([log-file (with-handlers ([exn:fail:filesystem? - (lambda (exn) - (open-input-string ""))]) - (open-input-file exprs-dat-file))]) - (λ (gui-eval get-predicate? get-render get-get-width get-get-height) - (lambda (ev catching-exns? expr) - (with-handlers ([exn:fail? (lambda (exn) - (if catching-exns? - (raise exn) - (void)))]) - (let ([v (read log-file)]) - (if (eof-object? v) - (error "expression not in log file") - (let ([v (deserialize v)]) - (if (equal? v (if (syntax? expr) - (syntax->datum expr) - expr)) - (let ([v (read log-file)]) - (if (eof-object? v) - (error "expression result missing in log file") - (let ([v (deserialize v)]) - (if (gui-exn? v) - (raise (make-exn:fail - (gui-exn-message v) - (current-continuation-marks))) - v)))) - (error 'mreval - "expression does not match log file: ~e versus: ~e" - expr - v))))))))))) + (cond + [mred? + (define eh (scribble-eval-handler)) + (define log-file (open-output-file exprs-dat-file #:exists 'truncate/replace)) + (λ (gui-eval get-predicate? get-render get-get-width get-get-height) + (lambda (ev catching-exns? expr) + (write (serialize (if (syntax? expr) + (syntax->datum expr) + expr)) + log-file) + (newline log-file) + (flush-output log-file) + (let ([result (with-handlers ([exn:fail? (lambda (exn) (make-gui-exn (exn-message exn)))]) + ;; put the call to fixup-picts in the handlers + ;; so that errors in the user-supplied predicates & + ;; conversion functions show up in the rendered output + (fixup-picts (get-predicate?) + (get-render) + (get-get-width) + (get-get-height) + (eh ev catching-exns? expr)))]) + (write (serialize result) log-file) + (newline log-file) + (flush-output log-file) + (if (gui-exn? result) + (raise (make-exn:fail (gui-exn-message result) (current-continuation-marks))) + result))))] + [else + (define log-file + (with-handlers ([exn:fail:filesystem? (lambda (exn) (open-input-string ""))]) + (open-input-file exprs-dat-file))) + (λ (gui-eval get-predicate? get-render get-get-width get-get-height) + (lambda (ev catching-exns? expr) + (with-handlers ([exn:fail? (lambda (exn) + (if catching-exns? + (raise exn) + (void)))]) + (let ([v (read log-file)]) + (if (eof-object? v) + (error "expression not in log file") + (let ([v (deserialize v)]) + (if (equal? v + (if (syntax? expr) + (syntax->datum expr) + expr)) + (let ([v (read log-file)]) + (if (eof-object? v) + (error "expression result missing in log file") + (let ([v (deserialize v)]) + (if (gui-exn? v) + (raise (make-exn:fail (gui-exn-message v) + (current-continuation-marks))) + v)))) + (error 'mreval + "expression does not match log file: ~e versus: ~e" + expr + v))))))))])) (define image-counter 0) @@ -133,41 +133,40 @@ (let loop ([v v]) (cond [(predicate? v) - (let ([fn (build-string-path img-dir - (format "img~a.png" image-counter))]) - (set! image-counter (add1 image-counter)) - (let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))]) - (send pss set-mode 'file) - (send pss set-file (path-replace-suffix fn #".pdf")) - (parameterize ([(gui-eval 'current-ps-setup) pss]) - (let ([xb (box 0)] - [yb (box 0)]) - (send pss get-scaling xb yb) - (new (gui-eval 'pdf-dc%) - [interactive #f] - [width (* (unbox xb) (get-width v))] - [height (* (unbox yb) (get-height v))]))))]) - (send dc start-doc "Image") - (send dc start-page) - (render v dc 0 0) - (send dc end-page) - (send dc end-doc)) - (let* ([bm (make-object (gui-eval 'bitmap%) + (define fn (build-string-path img-dir (format "img~a.png" image-counter))) + (set! image-counter (add1 image-counter)) + (let ([dc (let ([pss (make-object (gui-eval 'ps-setup%))]) + (send pss set-mode 'file) + (send pss set-file (path-replace-suffix fn #".pdf")) + (parameterize ([(gui-eval 'current-ps-setup) pss]) + (let ([xb (box 0)] + [yb (box 0)]) + (send pss get-scaling xb yb) + (new (gui-eval 'pdf-dc%) + [interactive #f] + [width (* (unbox xb) (get-width v))] + [height (* (unbox yb) (get-height v))]))))]) + (send dc start-doc "Image") + (send dc start-page) + (render v dc 0 0) + (send dc end-page) + (send dc end-doc)) + (define bm + (make-object (gui-eval 'bitmap%) (inexact->exact (ceiling (get-width v))) - (inexact->exact (ceiling (get-height v))))] - [dc (make-object (gui-eval 'bitmap-dc%) bm)]) - (send dc set-smoothing 'aligned) - (send dc clear) - (render v dc 0 0) - (send bm save-file fn 'png) - (make-image-element - #f - (list "[image]") - ;; Be sure to use a string rather than a path, because - ;; it gets recorded in "exprs.dat". - (path->string (path-replace-suffix fn #"")) - '(".pdf" ".png") - 1.0)))] + (inexact->exact (ceiling (get-height v))))) + (define dc (make-object (gui-eval 'bitmap-dc%) bm)) + (send dc set-smoothing 'aligned) + (send dc clear) + (render v dc 0 0) + (send bm save-file fn 'png) + (make-image-element #f + (list "[image]") + ;; Be sure to use a string rather than a path, because + ;; it gets recorded in "exprs.dat". + (path->string (path-replace-suffix fn #"")) + '(".pdf" ".png") + 1.0)] [(pair? v) (cons (loop (car v)) (loop (cdr v)))] [(serializable? v) v]