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/base.rkt b/scribble-lib/scribble/base.rkt
index e678a59937..767b51d1d1 100644
--- a/scribble-lib/scribble/base.rkt
+++ b/scribble-lib/scribble/base.rkt
@@ -29,23 +29,22 @@
#:rest (listof pre-content?)
part-start?))
-(provide/contract
- [title (->* ()
- (#:tag (or/c #f string? (listof string?))
- #:tag-prefix (or/c #f string? module-path? hash?)
- #:style (or/c style? string? symbol? (listof symbol?) #f)
- #:version (or/c string? #f)
- #:date (or/c string? #f)
- #:index-extras desc-extras/c)
- #:rest (listof pre-content?)
- title-decl?)]
- [section (title-like-contract)]
- [subsection (title-like-contract)]
- [subsubsection (title-like-contract)]
- [subsubsub*section (->* ()
- (#:tag (or/c #f string? (listof string?)))
- #:rest (listof pre-content?)
- block?)])
+(provide (contract-out
+ [title
+ (->* ()
+ (#:tag (or/c #f string? (listof string?))
+ #:tag-prefix (or/c #f string? module-path? hash?)
+ #:style (or/c style? string? symbol? (listof symbol?) #f)
+ #:version (or/c string? #f)
+ #:date (or/c string? #f)
+ #:index-extras desc-extras/c)
+ #:rest (listof pre-content?)
+ title-decl?)]
+ [section (title-like-contract)]
+ [subsection (title-like-contract)]
+ [subsubsection (title-like-contract)]
+ [subsubsub*section
+ (->* () (#:tag (or/c #f string? (listof string?))) #:rest (listof pre-content?) block?)]))
(provide include-section)
(define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain]
@@ -131,9 +130,8 @@
;; ----------------------------------------
-(provide/contract
- [author (->* (content?) () #:rest (listof content?) block?)]
- [author+email (->* (content? string?) (#:obfuscate? any/c) element?)])
+(provide (contract-out [author (->* (content?) () #:rest (listof content?) block?)]
+ [author+email (->* (content? string?) (#:obfuscate? any/c) element?)]))
(define (author . auths)
(make-paragraph
@@ -142,10 +140,9 @@
(case (length auths)
[(1) auths]
[(2) (list (car auths) nl "and " (cadr auths))]
- [else (let ([r (reverse auths)])
- (append (add-between (reverse (cdr r))
- (make-element #f (list "," nl)))
- (list "," nl "and " (car r))))]))))
+ [else (define r (reverse auths))
+ (append (add-between (reverse (cdr r)) (make-element #f (list "," nl)))
+ (list "," nl "and " (car r)))]))))
(define (author+email name email #:obfuscate? [obfuscate? #f])
(make-element #f
@@ -173,15 +170,10 @@
(provide items/c)
-(provide/contract
- [itemlist (->* ()
- (#:style (or/c style? string? symbol? #f))
- #:rest (listof items/c)
- itemization?)]
- [item (->* ()
- ()
- #:rest (listof pre-flow?)
- item?)])
+(provide (contract-out
+ [itemlist
+ (->* () (#:style (or/c style? string? symbol? #f)) #:rest (listof items/c) itemization?)]
+ [item (->* () () #:rest (listof pre-flow?) item?)]))
(provide/contract
[item? (any/c . -> . boolean?)])
diff --git a/scribble-lib/scribble/tag.rkt b/scribble-lib/scribble/tag.rkt
index 3d2c4eef8c..fa9e861715 100644
--- a/scribble-lib/scribble/tag.rkt
+++ b/scribble-lib/scribble/tag.rkt
@@ -48,58 +48,45 @@
(let ([v (if (list? v)
(map intern-taglet v)
(datum-intern-literal v))])
- (if (or (string? v)
- (bytes? v)
- (list? v))
- (let ([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)))
- v)))
+ (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))]
+ [else v])))
(define (do-module-path-index->taglet mod)
;; Derive the name from the module path:
- (let ([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)))))
+ (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))))
(define collapsed (make-weak-hasheq))
(define (module-path-index->taglet mod)
- (or (hash-ref collapsed mod #f)
- (let ([v (do-module-path-index->taglet mod)])
- (hash-set! collapsed mod v)
- v)))
+ (hash-ref! collapsed mod (λ () (do-module-path-index->taglet mod))))
(define (module-path-prefix->string p)
(datum-intern-literal
@@ -123,9 +110,8 @@
(define (definition-tag->class/interface-tag t) (cons 'class/intf (cdr t)))
(define (class/interface-tag->constructor-tag t) (cons 'constructor (cdr t)))
(define (get-class/interface-and-method meth-tag)
- (match meth-tag
- [`(meth ((,_ ,class/interface) ,method))
- (values class/interface method)]))
+ (match-define `(meth ((,_ ,class/interface) ,method)) meth-tag)
+ (values class/interface method))
(define (definition-tag? x) (and (tag? x) (equal? (car x) 'def)))
(define (class/interface-tag? x) (and (tag? x) (equal? (car x) 'class/intf)))
(define (method-tag? x) (and (tag? x) (equal? (car x) 'meth)))
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?]