diff --git a/scribble-html-lib/scribble/html/html.rkt b/scribble-html-lib/scribble/html/html.rkt
index 9bd71e3f96..71f1b82977 100644
--- a/scribble-html-lib/scribble/html/html.rkt
+++ b/scribble-html-lib/scribble/html/html.rkt
@@ -186,11 +186,11 @@
(define-values [attrs body] (attributes+body args))
(make-element
'script attrs
- `("\n" ,(set-prefix 0 (apply cdata #:line-prefix "//" body)) "\n")))
+ (list "\n" (set-prefix 0 (apply cdata #:line-prefix "//" body)) "\n")))
(provide style/inline)
(define (style/inline . args)
(define-values [attrs body] (attributes+body args))
- (make-element 'style attrs `("\n" ,body "\n")))
+ (make-element 'style attrs (list "\n" body "\n")))
;; ----------------------------------------------------------------------------
;; Entities
diff --git a/scribble-html-lib/scribble/html/resource.rkt b/scribble-html-lib/scribble/html/resource.rkt
index 454ff63393..8923f7c00c 100644
--- a/scribble-html-lib/scribble/html/resource.rkt
+++ b/scribble-html-lib/scribble/html/resource.rkt
@@ -57,11 +57,10 @@
(set! cached-roots
(cons roots
(and (list? roots) (pair? roots)
- (map (lambda (root)
- (list* (regexp-match* #rx"[^/]+" (car root))
- (regexp-replace #rx"/$" (cadr root) "")
- (cddr root)))
- roots)))))
+ (for/list ([root (in-list roots)])
+ (list* (regexp-match* #rx"[^/]+" (car root))
+ (regexp-replace #rx"/$" (cadr root) "")
+ (cddr root)))))))
(cdr cached-roots))
;; a utility for relative paths, taking the above `default-file' and
@@ -70,22 +69,23 @@
(define file* (if (equal? file default-file) "" file))
(define roots (current-url-roots))
(define (find-root path mode)
- (ormap (lambda (root+url+flags)
- (let loop ([r (car root+url+flags)] [p path])
- (if (pair? r)
- (and (pair? p) (equal? (car p) (car r))
- (loop (cdr r) (cdr p)))
- (case mode
- [(get-path) `(,(cadr root+url+flags)
- ,@p
- ,(if (and (equal? file* "")
- (memq 'index (cddr root+url+flags)))
- default-file
- file*))]
- [(get-abs-or-true)
- (if (memq 'abs (cddr root+url+flags)) `("" ,@p) #t)]
- [else (error 'relativize "internal error: ~e" mode)]))))
- roots))
+ (for/or ([root+url+flags (in-list roots)])
+ (let loop ([r (car root+url+flags)]
+ [p path])
+ (if (pair? r)
+ (and (pair? p) (equal? (car p) (car r)) (loop (cdr r) (cdr p)))
+ (case mode
+ [(get-path)
+ `(,(cadr root+url+flags) ,@p
+ ,(if (and (equal? file* "")
+ (memq 'index (cddr root+url+flags)))
+ default-file
+ file*))]
+ [(get-abs-or-true)
+ (if (memq 'abs (cddr root+url+flags))
+ `("" ,@p)
+ #t)]
+ [else (error 'relativize "internal error: ~e" mode)])))))
(define result
(let loop ([t tgtdir] [c curdir] [pfx '()])
(cond
@@ -165,9 +165,11 @@
(define t (make-hash))
(define-syntax-rule (S body) (call-with-semaphore s (lambda () body)))
(values (lambda (path renderer)
- (S (if (hash-ref t path #f)
- (error 'resource "path used for two resources: ~e" path)
- (begin (hash-set! t path #t) (set! l (cons renderer l))))))
+ (S (cond
+ [(hash-ref t path #f) (error 'resource "path used for two resources: ~e" path)]
+ [else
+ (hash-set! t path #t)
+ (set! l (cons renderer l))])))
(lambda () (S (begin0 (reverse l) (set! l '())))))))
;; `#:exists' determines what happens when the render destination exists, it
@@ -180,32 +182,33 @@
(define (resource path0 renderer #:exists [exists 'delete-file])
(define (bad reason) (error 'resource "bad path, ~a: ~e" reason path0))
(unless (string? path0) (bad "must be a string"))
- (for ([x (in-list '([#rx"^/" "must be relative"]
- [#rx"//" "must not have empty elements"]
- [#rx"(?:^|/)[.][.]?(?:/|$)"
- "must not contain `.' or `..'"]))])
- (when (regexp-match? (car x) path0) (bad (cadr x))))
+ (for ([x (in-list '([#rx"^/" "must be relative"] [#rx"//" "must not have empty elements"]
+ [#rx"(?:^|/)[.][.]?(?:/|$)"
+ "must not contain `.' or `..'"]))]
+ #:when (regexp-match? (car x) path0))
+ (bad (cadr x)))
(define path (regexp-replace #rx"(?<=^|/)$" path0 default-file))
(define-values [dirpathlist filename]
(let-values ([(l r) (split-at-right (regexp-split #rx"/" path) 1)])
(values l (car r))))
(define (render)
(let loop ([ps dirpathlist])
- (if (pair? ps)
- (begin (unless (directory-exists? (car ps))
- (if (or (file-exists? (car ps)) (link-exists? (car ps)))
- (bad "exists as a file/link")
- (make-directory (car ps))))
- (parameterize ([current-directory (car ps)])
- (loop (cdr ps))))
- (begin (cond [(not exists)] ; do nothing
- [(or (file-exists? filename) (link-exists? filename))
- (delete-file filename)]
- [(directory-exists? filename)
- (bad "exists as directory")])
- (parameterize ([rendered-dirpath dirpathlist])
- (printf " ~a\n" path)
- (renderer filename))))))
+ (cond
+ [(pair? ps)
+ (unless (directory-exists? (car ps))
+ (if (or (file-exists? (car ps)) (link-exists? (car ps)))
+ (bad "exists as a file/link")
+ (make-directory (car ps))))
+ (parameterize ([current-directory (car ps)])
+ (loop (cdr ps)))]
+ [else
+ (cond
+ [(not exists)] ; do nothing
+ [(or (file-exists? filename) (link-exists? filename)) (delete-file filename)]
+ [(directory-exists? filename) (bad "exists as directory")])
+ (parameterize ([rendered-dirpath dirpathlist])
+ (printf " ~a\n" path)
+ (renderer filename))])))
(define absolute-url
(lazy (define url (relativize filename dirpathlist '()))
(if (url-roots)
diff --git a/scribble-html-lib/scribble/html/xml.rkt b/scribble-html-lib/scribble/html/xml.rkt
index 6e4f416f96..51fa3b3ed3 100644
--- a/scribble-html-lib/scribble/html/xml.rkt
+++ b/scribble-html-lib/scribble/html/xml.rkt
@@ -106,16 +106,14 @@
;; null body means a lone tag, tags that should always have a closer will
;; have a '(#f) as their body (see below)
(list (with-writer #f "<" tag)
- (map (lambda (attr)
- (define name (car attr))
- (define val (cdr attr))
- (cond [(not val) #f]
- ;; #t means just mention the attribute
- [(eq? #t val) (with-writer #f (list " " name))]
- [else (list (with-writer #f (list " " name "=\""))
- val
- (with-writer #f "\""))]))
- attrs)
+ (for/list ([attr (in-list attrs)])
+ (define name (car attr))
+ (define val (cdr attr))
+ (cond
+ [(not val) #f]
+ ;; #t means just mention the attribute
+ [(eq? #t val) (with-writer #f (list " " name))]
+ [else (list (with-writer #f (list " " name "=\"")) val (with-writer #f "\""))]))
(if (null? body)
(with-writer #f " />")
(list (with-writer #f ">")
diff --git a/scribble-lib/scribble/private/doc-begin.rkt b/scribble-lib/scribble/private/doc-begin.rkt
index c41e555a0c..e7e51f2e77 100644
--- a/scribble-lib/scribble/private/doc-begin.rkt
+++ b/scribble-lib/scribble/private/doc-begin.rkt
@@ -66,22 +66,15 @@
#'(check-pre-part s (quote-syntax loc))))]))
(define (check-pre-part v loc-stx)
- (if (pre-part? v)
- v
- (error
- (format
- "~a: not valid in document body (need a pre-part for decode) in: ~e"
- (cond
- [(and (syntax-source loc-stx)
- (syntax-line loc-stx))
- (format "~a:~a:~a"
- (syntax-source loc-stx)
- (syntax-line loc-stx)
- (syntax-column loc-stx))]
- [(and (syntax-source loc-stx)
- (syntax-position loc-stx))
- (format "~a:::~a"
- (syntax-source loc-stx)
- (syntax-position loc-stx))]
- [else 'document])
- v))))
+ (unless (pre-part? v)
+ (error
+ (format
+ "~a: not valid in document body (need a pre-part for decode) in: ~e"
+ (cond
+ [(and (syntax-source loc-stx) (syntax-line loc-stx))
+ (format "~a:~a:~a" (syntax-source loc-stx) (syntax-line loc-stx) (syntax-column loc-stx))]
+ [(and (syntax-source loc-stx) (syntax-position loc-stx))
+ (format "~a:::~a" (syntax-source loc-stx) (syntax-position loc-stx))]
+ [else 'document])
+ v)))
+ v)
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-proc.rkt b/scribble-lib/scribble/private/manual-proc.rkt
index 89c3d59e3f..f1390a25e2 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?))
diff --git a/scribble-text-lib/scribble/text/output.rkt b/scribble-text-lib/scribble/text/output.rkt
index 027034b023..d2480f4034 100644
--- a/scribble-text-lib/scribble/text/output.rkt
+++ b/scribble-text-lib/scribble/text/output.rkt
@@ -112,11 +112,12 @@
(cond
[(pair? nls)
(define nl (car nls))
- (if (regexp-match? #rx"^ *$" x start (car nl))
- (newline p) ; only spaces before the end of the line
- (begin
- (output-pfx col pfx lpfx)
- (write x p start (cdr nl))))
+ (cond
+ [(regexp-match? #rx"^ *$" x start (car nl))
+ (newline p)] ; only spaces before the end of the line
+ [else
+ (output-pfx col pfx lpfx)
+ (write x p start (cdr nl))])
(loop (cdr nl) (cdr nls) 0 0)]
;; last substring from here (always set lpfx state when done)
[(start . = . len) (set-mcdr! pfxs lpfx)]
@@ -279,10 +280,7 @@
[(eq? p (car last)) (cdr last)]
[else
(define s
- (or (hash-ref t p #f)
- (let ([s (mcons 0 0)])
- (hash-set! t p s)
- s)))
+ (hash-ref! t p (λ () (mcons 0 0))))
(set! last (cons p s))
s]))))
diff --git a/scribble-text-lib/scribble/text/syntax-utils.rkt b/scribble-text-lib/scribble/text/syntax-utils.rkt
index 0577c13783..955ff8c1f7 100644
--- a/scribble-text-lib/scribble/text/syntax-utils.rkt
+++ b/scribble-text-lib/scribble/text/syntax-utils.rkt
@@ -145,23 +145,24 @@
(loop (append (syntax->list #'(x ...)) (cdr exprs)) ds es)]
[(define-syntaxes (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
- (if (null? es)
- (let ([ids (syntax->list #'(id ...))])
- (syntax-local-bind-syntaxes ids
- (local-transformer-expand #'rhs 'expression '())
- (car ctx))
- (loop (cdr exprs) (cons (rebuild-bindings) ds) es))
- ;; return the unexpanded expr, to be re-expanded later, in the
- ;; right contexts
- (values (reverse ds) (reverse es) exprs))]
+ (cond
+ [(null? es)
+ (define ids (syntax->list #'(id ...)))
+ (syntax-local-bind-syntaxes ids
+ (local-transformer-expand #'rhs 'expression '())
+ (car ctx))
+ (loop (cdr exprs) (cons (rebuild-bindings) ds) es)]
+ ;; return the unexpanded expr, to be re-expanded later, in the
+ ;; right contexts
+ [else (values (reverse ds) (reverse es) exprs)])]
[(define-values (id ...) rhs)
(andmap identifier? (syntax->list #'(id ...)))
- (if (null? es)
- (begin
- (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f (car ctx))
- (loop (cdr exprs) (cons (rebuild-bindings) ds) es))
- ;; same note here
- (values (reverse ds) (reverse es) exprs))]
+ (cond
+ [(null? es)
+ (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #f (car ctx))
+ (loop (cdr exprs) (cons (rebuild-bindings) ds) es)]
+ ;; same note here
+ [else (values (reverse ds) (reverse es) exprs)])]
[_ (loop (cdr exprs) ds (cons expr* es))])])))
(define-syntax (begin/collect* stx) ; helper, has a boolean flag first
(define-values [exprs always-list?]