diff --git a/scribble-lib/scribble/private/define-popup.rkt b/scribble-lib/scribble/private/define-popup.rkt index 946d02ca49..8e7fa40db5 100644 --- a/scribble-lib/scribble/private/define-popup.rkt +++ b/scribble-lib/scribble/private/define-popup.rkt @@ -13,21 +13,12 @@ [found-open? (cond [(char=? char #\}) - (regexp-replace - #rx"^[\n ]*" - (regexp-replace - #rx"[\n ]*$" - (apply string (reverse chars)) - "") - "")] - [else - (loop (+ pos 1) #t (cons char chars))])] - [else - (cond - [(char=? char #\{) - (loop (+ pos 1) #t '())] - [else - (loop (+ pos 1) #f '())])])] + (regexp-replace #rx"^[\n ]*" + (regexp-replace #rx"[\n ]*$" (apply string (reverse chars)) "") + "")] + [else (loop (+ pos 1) #t (cons char chars))])] + [(char=? char #\{) (loop (+ pos 1) #t '())] + [else (loop (+ pos 1) #f '())])] [else #f]))) (define define-popup 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-mod.rkt b/scribble-lib/scribble/private/manual-mod.rkt index 9f680e93b6..d808e32911 100644 --- a/scribble-lib/scribble/private/manual-mod.rkt +++ b/scribble-lib/scribble/private/manual-mod.rkt @@ -299,12 +299,9 @@ pkg-spec)))) libs-specs)) (append (if link-target? - (map (lambda (modpath) - (make-part-tag-decl - (intern-taglet - `(mod-path ,(datum-intern-literal - (element->string modpath)))))) - modpaths) + (for/list ([modpath (in-list modpaths)]) + (make-part-tag-decl (intern-taglet `(mod-path ,(datum-intern-literal + (element->string modpath)))))) null) (flow-paragraphs (decode-flow content))))))) @@ -334,12 +331,12 @@ #'(list pkg ...) #'#f)]) (let ([libs (syntax->list #'(lib ... plib ...))]) - (for ([l libs]) - (unless (or (syntax-case l (unquote) - [(unquote _) #t] - [_ #f]) - (module-path? (syntax->datum l))) - (raise-syntax-error #f "not a module path" stx l))) + (for ([l libs] + #:unless (or (syntax-case l (unquote) + [(unquote _) #t] + [_ #f]) + (module-path? (syntax->datum l)))) + (raise-syntax-error #f "not a module path" stx l)) (when (null? libs) (raise-syntax-error #f "need at least one module path" stx)) #'(*declare-exporting `(lib ...) `(plib ...) packages)))])) diff --git a/scribble-lib/scribble/private/manual-proc.rkt b/scribble-lib/scribble/private/manual-proc.rkt index 89c3d59e3f..76f51b2598 100644 --- a/scribble-lib/scribble/private/manual-proc.rkt +++ b/scribble-lib/scribble/private/manual-proc.rkt @@ -857,42 +857,38 @@ (make-just-context (car name) (car (syntax-e stx-id))) stx-id)]) - (if link? - (let () - (define (gen defn?) - ((if defn? annote-exporting-library values) - (to-element #:defn? defn? name-id))) - (define content (gen #t)) - (define ref-content (gen #f)) - (make-target-element* - (lambda (s c t) - (make-toc-target2-element s c t ref-content)) - (if (pair? name) - (car (syntax-e stx-id)) - stx-id) - content - (let ([name (if (pair? name) (car name) name)]) - (list* (list 'info name) - (list 'type 'struct: name) - (list 'predicate name '?) - (append - (if cname-id - (list (list 'constructor (syntax-e cname-id))) - null) - (map (lambda (f) - (list 'accessor name '- - (field-name f))) - fields) - (filter-map - (lambda (f) - (and (or (not immutable?) - (and (pair? (car f)) - (memq '#:mutable - (car f)))) - (list 'mutator 'set- name '- - (field-name f) '!))) - fields)))))) - (to-element #:defn? #t name-id)))]) + (cond + [link? + (define (gen defn?) + ((if defn? annote-exporting-library values) (to-element #:defn? defn? + name-id))) + (define content (gen #t)) + (define ref-content (gen #f)) + (make-target-element* + (lambda (s c t) (make-toc-target2-element s c t ref-content)) + (if (pair? name) + (car (syntax-e stx-id)) + stx-id) + content + (let ([name (if (pair? name) + (car name) + name)]) + (list* (list 'info name) + (list 'type 'struct: name) + (list 'predicate name '?) + (append + (if cname-id + (list (list 'constructor (syntax-e cname-id))) + null) + (map (lambda (f) (list 'accessor name '- (field-name f))) + fields) + (filter-map + (lambda (f) + (and (or (not immutable?) + (and (pair? (car f)) (memq '#:mutable (car f)))) + (list 'mutator 'set- name '- (field-name f) '!))) + fields)))))] + [else (to-element #:defn? #t name-id)]))]) (if (pair? name) (make-element #f @@ -913,17 +909,17 @@ (map sym-length (append (if (pair? name) name (list name)) (map field-name fields))) - (map (lambda (f) - (match (car f) - [(? symbol?) 0] - [(list name) 2] ;; the extra [ ] - [(list* name field-opts) - ;; '[' ']' - (apply + 2 - (for/list ([field-opt (in-list field-opts)]) - ;; and " #:" - (+ 3 (string-length (keyword->string field-opt)))))])) - fields)))]) + (for/list ([f (in-list fields)]) + (match (car f) + [(? symbol?) 0] + [(list name) 2] ;; the extra [ ] + [(list* name field-opts) + ;; '[' ']' + (apply + + 2 + (for/list ([field-opt (in-list field-opts)]) + ;; and " #:" + (+ 3 (string-length (keyword->string field-opt)))))]))))]) (cond [(and (short-width . < . max-proto-width) (not keyword-modifiers?)) @@ -931,9 +927,7 @@ (make-omitable-paragraph (list (to-element - `(,(racket struct) - ,the-name - ,(map field-view fields)))))] + (list (racket struct) the-name (map field-view fields)))))] [else ;; Multi-line view (leaving out last paren if keywords follow): (define one-right-column? diff --git a/scribble-lib/scribble/private/manual-style.rkt b/scribble-lib/scribble/private/manual-style.rkt index a4b855628e..81d66858cf 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))) diff --git a/scribble-lib/scribble/private/manual-vars.rkt b/scribble-lib/scribble/private/manual-vars.rkt index 3321674190..a707d8270e 100644 --- a/scribble-lib/scribble/private/manual-vars.rkt +++ b/scribble-lib/scribble/private/manual-vars.rkt @@ -17,8 +17,7 @@ (define-struct (box-splice splice) ()) -(provide/contract - [struct (box-splice splice) ([run list?])]) ; XXX ugly copying +(provide (contract-out (struct (box-splice splice) ([run list?])))) ; XXX ugly copying (provide deftogether *deftogether with-racket-variables with-togetherable-racket-variables @@ -172,47 +171,42 @@ (list (make-table boxed-style - (map - (lambda (box) - (unless (and (box-splice? box) - (= 1 (length (splice-run box))) - (nested-flow? (car (splice-run box))) - (eq? vertical-inset-style (nested-flow-style (car (splice-run box)))) - (let ([l (nested-flow-blocks (car (splice-run box)))]) - (= 1 (length l)) - (table? (car l)) - (eq? boxed-style (table-style (car l))))) - (error 'deftogether - "element is not a boxing splice containing a single nested-flow with a single table: ~e" - box)) - (list (make-flow (list (make-table - "together" - (table-flowss (car (nested-flow-blocks (car (splice-run box)))))))))) - boxes)))) + (for/list ([box (in-list boxes)]) + (unless (and (box-splice? box) + (= 1 (length (splice-run box))) + (nested-flow? (car (splice-run box))) + (eq? vertical-inset-style (nested-flow-style (car (splice-run box)))) + (let ([l (nested-flow-blocks (car (splice-run box)))]) + (= 1 (length l)) + (table? (car l)) + (eq? boxed-style (table-style (car l))))) + (error + 'deftogether + "element is not a boxing splice containing a single nested-flow with a single table: ~e" + box)) + (list (make-flow (list (make-table "together" + (table-flowss (car (nested-flow-blocks + (car (splice-run box))))))))))))) (body-thunk)))) (define-syntax (deftogether stx) (syntax-parse stx [(_ (def ...+) . body) (with-syntax ([((_ (lit ...) (var ...) decl) ...) - (map (lambda (def) - (define exp-def - (local-expand - def - (list (make-deftogether-tag)) - (cons - #'with-togetherable-racket-variables* - (kernel-form-identifier-list)))) - (syntax-case exp-def (with-togetherable-racket-variables*) - [(with-togetherable-racket-variables* lits vars decl) - exp-def] - [_ - (raise-syntax-error - #f - "sub-form is not a documentation form that can be combined" - stx - def)])) - (syntax->list #'(def ...)))]) + (for/list ([def (in-list (syntax->list #'(def ...)))]) + (define exp-def + (local-expand def + (list (make-deftogether-tag)) + (cons #'with-togetherable-racket-variables* + (kernel-form-identifier-list)))) + (syntax-case exp-def (with-togetherable-racket-variables*) + [(with-togetherable-racket-variables* lits vars decl) exp-def] + [_ + (raise-syntax-error + #f + "sub-form is not a documentation form that can be combined" + stx + def)]))]) #'(with-togetherable-racket-variables (lit ... ...) (var ... ...) 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]