From e44a5bb9f19528bcebb432abf699833d1d50a6c7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jens=20Axel=20S=C3=B8gaard?= <jensaxel@soegaard.net>
Date: Mon, 14 Oct 2019 16:10:44 +0200
Subject: [PATCH 01/17] Fix transposition in error message (#215)
---
scribble-html-lib/scribble/html/xml.rkt | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/scribble-html-lib/scribble/html/xml.rkt b/scribble-html-lib/scribble/html/xml.rkt
index b41d93c5..6e4f416f 100644
--- a/scribble-html-lib/scribble/html/xml.rkt
+++ b/scribble-html-lib/scribble/html/xml.rkt
@@ -33,7 +33,7 @@
(let loop ([xs xs] [as '()])
(define a (and (pair? xs) (attribute->symbol (car xs))))
(cond [(not a) (values (reverse as) xs)]
- [(null? (cdr xs)) (error 'attriubtes+body
+ [(null? (cdr xs)) (error 'attributes+body
"missing attribute value for `~s:'" a)]
[else (loop (cddr xs) (cons (cons a (cadr xs)) as))])))
From 431bb95c7b56687c94cb3f89e681c284bdf5a2c6 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 15 Oct 2019 19:01:40 -0600
Subject: [PATCH 02/17] improve markdown renderer, including support for
section links
---
.../scribblings/scribble/manual.scrbl | 2 +-
.../scribblings/scribble/renderer.scrbl | 7 +
scribble-lib/info.rkt | 2 +-
scribble-lib/scribble/markdown-render.rkt | 138 ++++++++++++++----
scribble-lib/scribble/run.rkt | 2 +
5 files changed, 120 insertions(+), 31 deletions(-)
diff --git a/scribble-doc/scribblings/scribble/manual.scrbl b/scribble-doc/scribblings/scribble/manual.scrbl
index a1bffa2b..dda1ebe0 100644
--- a/scribble-doc/scribblings/scribble/manual.scrbl
+++ b/scribble-doc/scribblings/scribble/manual.scrbl
@@ -2201,7 +2201,7 @@ For HTML rendering:
@filepath{manual-style.css} from the @filepath{scribble}
collection in @racket[html-defaults].}
- @item{The file @filepath{manual-files.css} from the
+ @item{The file @filepath{manual-fonts.css} from the
@filepath{scribble} collection is designated as an additional
accompanying file in @racket[html-defaults].}
diff --git a/scribble-doc/scribblings/scribble/renderer.scrbl b/scribble-doc/scribblings/scribble/renderer.scrbl
index 0242a65a..4dfd9dc2 100644
--- a/scribble-doc/scribblings/scribble/renderer.scrbl
+++ b/scribble-doc/scribblings/scribble/renderer.scrbl
@@ -607,6 +607,13 @@ Code blocks are marked using the
"Github convention"] @verbatim{```racket} so that they are lexed and
formatted as Racket code.}}
+@defboolparam[current-markdown-link-sections enabled?]{
+
+Determines whether section links within an output document are
+rendered as a section link. The default is @racket[#f].
+
+@history[#:added "1.31"]}
+
@; ----------------------------------------
@section{HTML Renderer}
diff --git a/scribble-lib/info.rkt b/scribble-lib/info.rkt
index 674af7ef..d23ca4de 100644
--- a/scribble-lib/info.rkt
+++ b/scribble-lib/info.rkt
@@ -23,4 +23,4 @@
(define pkg-authors '(mflatt eli))
-(define version "1.30")
+(define version "1.31")
diff --git a/scribble-lib/scribble/markdown-render.rkt b/scribble-lib/scribble/markdown-render.rkt
index 58847f74..16604c53 100644
--- a/scribble-lib/scribble/markdown-render.rkt
+++ b/scribble-lib/scribble/markdown-render.rkt
@@ -4,7 +4,10 @@
"private/render-utils.rkt"
racket/class racket/port racket/list racket/string racket/match
scribble/text/wrap)
-(provide render-mixin)
+(provide render-mixin
+ current-markdown-link-sections)
+
+(define current-markdown-link-sections (make-parameter #f))
(define current-indent (make-parameter 0))
(define (make-indent amt)
@@ -17,6 +20,9 @@
(indent))
(define note-depth (make-parameter 0))
+(define in-toc (make-parameter #f))
+
+(define markdown-part-tag 'markdown-section)
(define (render-mixin %)
(class %
@@ -37,6 +43,16 @@
format-number
number-depth)
+ (define/override (collect-part-tags d ci number)
+ (for ([t (part-tags d)])
+ (let ([t (generate-tag t ci)])
+ (collect-put! ci
+ t
+ (vector (or (part-title-content d) '("???"))
+ (add-current-tag-prefix t)
+ number
+ markdown-part-tag)))))
+
(define/override (render-part d ht)
(let ([number (collected-info-number (part-collected-info d ht))])
(unless (part-style? d 'hidden)
@@ -153,25 +169,32 @@
(write-string (make-string (note-depth) #\>))
(unless (zero? (note-depth))
(write-string " ")))
- (define o (open-output-string))
- (parameterize ([current-output-port o])
- (super render-paragraph p part ri))
- ;; 1. Remove newlines so we can re-wrap the text.
- ;;
- ;; 2. Combine adjacent code spans into one. These result from
- ;; something like @racket[(x y)] being treated as multiple
- ;; RktXXX items rather than one. (Although it would be
- ;; more-correct to handle them at that level, I don't easily see
- ;; how. As a result I'm handling it after-the-fact, at the
- ;; text/Markdown stage.)
- (define to-wrap (regexp-replaces (get-output-string o)
- '([#rx"\n" " "] ;1
- [#rx"``" ""]))) ;2
- (define lines (wrap-line (string-trim to-wrap) (- 72 (current-indent))))
- (write-note)
- (write-string (car lines))
- (for ([line (in-list (cdr lines))])
- (newline) (indent) (write-note) (write-string line))
+ (cond
+ [(in-toc)
+ (write-note)
+ (super render-paragraph p part ri)
+ ;; two spaces at a line end creates a line break:
+ (write-string " ")]
+ [else
+ (define o (open-output-string))
+ (parameterize ([current-output-port o])
+ (super render-paragraph p part ri))
+ ;; 1. Remove newlines so we can re-wrap the text.
+ ;;
+ ;; 2. Combine adjacent code spans into one. These result from
+ ;; something like @racket[(x y)] being treated as multiple
+ ;; RktXXX items rather than one. (Although it would be
+ ;; more-correct to handle them at that level, I don't easily see
+ ;; how. As a result I'm handling it after-the-fact, at the
+ ;; text/Markdown stage.)
+ (define to-wrap (regexp-replaces (get-output-string o)
+ '([#rx"\n" " "] ;1
+ [#rx"``" ""]))) ;2
+ (define lines (wrap-line (string-trim to-wrap) (- 72 (current-indent))))
+ (write-note)
+ (write-string (car lines))
+ (for ([line (in-list (cdr lines))])
+ (newline) (indent) (write-note) (write-string line))])
(newline)
null)
@@ -230,10 +253,10 @@
[(and (code? i) (not (in-code?)))
(recurse-wrapped "`" in-code?)]
- [(and (bold? i) (not (in-bold?)))
+ [(and (bold? i) (not (in-bold?)) (not (in-code?)))
(recurse-wrapped "**" in-bold?)]
- [(and (italic? i) (not (in-italic?)))
+ [(and (italic? i) (not (in-italic?)) (not (in-code?)))
(recurse-wrapped "_" in-italic?)]
[(and (preserve-spaces? i) (not (preserving-spaces?)))
@@ -248,15 +271,45 @@
(render-content i part ri))
(printf "](~a)" (sanitize-parens link))))]
+ [(and (link-element? i)
+ (current-markdown-link-sections)
+ (not (in-link?))
+ ;; Link to a part within this document?
+ (let ([vec (resolve-get part ri (link-element-tag i))])
+ (and (vector? vec)
+ (= 4 (vector-length vec))
+ (eq? markdown-part-tag (vector-ref vec 3))
+ vec)))
+ => (lambda (vec)
+ (define s (string-append
+ (let ([s (if (vector-ref vec 2)
+ (format-number (vector-ref vec 2) '() #t)
+ '())])
+ (if (null? s)
+ ""
+ (string-append (car s) " ")))
+ (content->string (vector-ref vec 0))))
+ (display "[")
+ (begin0
+ (parameterize ([in-link? #t])
+ (super render-content i part ri))
+ (display "](#")
+ (display (regexp-replace* #" "
+ (regexp-replace* #rx"[^a-zA-Z0-9_ -]" (string-downcase s) "")
+ #"-"))
+ (display ")")))]
+
[else (super render-content i part ri)]))
(define/override (render-nested-flow i part ri starting-item?)
(define s (nested-flow-style i))
(unless (memq 'decorative (style-properties s))
(define note? (equal? (style-name s) "refcontent"))
+ (define toc? (equal? (style-name s) 'table-of-contents))
(when note?
(note-depth (add1 (note-depth))))
- (begin0 (super render-nested-flow i part ri starting-item?)
+ (begin0 (parameterize ([in-toc (or toc? (in-toc))])
+ (super render-nested-flow i part ri starting-item?))
(when note?
(note-depth (sub1 (note-depth)))))))
@@ -270,8 +323,8 @@
[(rdquo) "\U201D"]
[(lsquo) "\U2018"]
[(rsquo) "\U2019"]
- [(lang) ">"]
- [(rang) "<"]
+ [(lang) "<"]
+ [(rang) ">"]
[(rarr) "->"]
[(nbsp) "\uA0"]
[(prime) "'"]
@@ -280,10 +333,17 @@
[else (error 'markdown-render "unknown element symbol: ~e"
i)]))]
[(string? i)
- (let* ([i (if (in-code?)
- (regexp-replace** i '([#rx"``" . "\U201C"]
- [#rx"''" . "\U201D"]))
- (regexp-replace* #px"([#_*`\\[\\(\\]\\)]{1})" i "\\\\\\1"))]
+ (let* ([i (cond
+ [(in-code?)
+ (regexp-replace** i '([#rx"``" . "\U201C"]
+ [#rx"''" . "\U201D"]))]
+ [(or (in-link?)
+ (regexp-match? #rx"^[(]" i)
+ (regexp-match? #rx"[]][(]" i))
+ (regexp-replace* #px"([#_*`\\[\\(\\]\\)]{1})" i "\\\\\\1")]
+ [else
+ ;; Avoid escaping parentheses
+ (regexp-replace* #px"([#_*`\\[\\]]{1})" i "\\\\\\1")])]
[i (if (preserving-spaces?)
(regexp-replace* #rx" " i "\uA0")
i)])
@@ -291,6 +351,26 @@
[else (write i)])
null)
+ (define/override (table-of-contents part ri)
+ (define t (super table-of-contents part ri))
+ (cond
+ [(current-markdown-link-sections)
+ ;; Table generated by `table-of-contents` always has one
+ ;; column, and each row has one paragraph that starts
+ ;; with a 'hspace element to indent
+ (nested-flow
+ (style 'table-of-contents null)
+ (for/list ([p (map car (table-blockss t))])
+ (define c (paragraph-content p))
+ (define keep-c (cdr c))
+ (define (spaces->depth n)
+ (add1 (quotient (- n 4) 2)))
+ (for/fold ([p (paragraph plain keep-c)]) ([s (in-range
+ (spaces->depth
+ (string-length (car (element-content (car c))))))])
+ (nested-flow (style "refcontent" null) (list p)))))]
+ [else t]))
+
(super-new)))
(define (regexp-replace** str ptns&reps)
diff --git a/scribble-lib/scribble/run.rkt b/scribble-lib/scribble/run.rkt
index da12b515..4ccdb3c4 100644
--- a/scribble-lib/scribble/run.rkt
+++ b/scribble-lib/scribble/run.rkt
@@ -106,6 +106,8 @@
(current-style-file file)]
[("--prefix") file "use given .html/.tex prefix (for doctype/documentclass)"
(current-prefix-file file)]
+ [("--link-section") "support section links for markdown"
+ (markdown:current-markdown-link-sections #t)]
#:multi
[("++extra") file "add given file"
(current-extra-files (cons file (current-extra-files)))]
From f46083a40c9a6a9aa92f8883115087e28a806169 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 31 Oct 2019 14:26:21 -0600
Subject: [PATCH 03/17] LaTeX output: \protect before \colorbox
Avoid problems when `\colorbox` ends up in a section title.
---
scribble-lib/scribble/scribble.tex | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/scribble-lib/scribble/scribble.tex b/scribble-lib/scribble/scribble.tex
index 1905e892..249fa4e7 100644
--- a/scribble-lib/scribble/scribble.tex
+++ b/scribble-lib/scribble/scribble.tex
@@ -83,8 +83,8 @@
\newcommand{\textsuper}[1]{$^{\hbox{\textsmaller{#1}}}$}
\newcommand{\intextcolor}[2]{\textcolor{#1}{#2}}
\newcommand{\intextrgbcolor}[2]{\textcolor[rgb]{#1}{#2}}
-\newcommand{\incolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\colorbox{#1}{#2}}}
-\newcommand{\inrgbcolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\colorbox[rgb]{#1}{#2}}}
+\newcommand{\incolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\protect\colorbox{#1}{#2}}}
+\newcommand{\inrgbcolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\protect\colorbox[rgb]{#1}{#2}}}
\newcommand{\plainlink}[1]{#1}
\newcommand{\techoutside}[1]{#1}
\newcommand{\techinside}[1]{#1}
From e25a02fd151f3b1bf797718213767bb472d530d7 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@indiana.edu>
Date: Mon, 4 Nov 2019 12:48:39 -0500
Subject: [PATCH 04/17] Relicense this repository under the Apache v2 and MIT
licenses.
* Move licensing information to the top level of the repo.
* Add README.md file with license and contributing info.
---
LICENSE | 10 ++++++++++
README.md | 24 ++++++++++++++++++++++++
scribble-doc/LICENSE.txt | 11 -----------
scribble-html-lib/LICENSE.txt | 11 -----------
scribble-lib/LICENSE.txt | 11 -----------
scribble-test/LICENSE.txt | 11 -----------
scribble-text-lib/LICENSE.txt | 11 -----------
scribble/LICENSE.txt | 11 -----------
8 files changed, 34 insertions(+), 66 deletions(-)
create mode 100644 LICENSE
create mode 100644 README.md
delete mode 100644 scribble-doc/LICENSE.txt
delete mode 100644 scribble-html-lib/LICENSE.txt
delete mode 100644 scribble-lib/LICENSE.txt
delete mode 100644 scribble-test/LICENSE.txt
delete mode 100644 scribble-text-lib/LICENSE.txt
delete mode 100644 scribble/LICENSE.txt
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 00000000..a2147765
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,10 @@
+This component of Racket is distributed under the under the Apache 2.0
+and MIT licenses. The user can choose the license under which they
+will be using the software. There may be other licenses within the
+distribution with which the user must also comply.
+
+See the files
+ https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt
+and
+ https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt
+for the full text of the licenses.
diff --git a/README.md b/README.md
new file mode 100644
index 00000000..0b339ec8
--- /dev/null
+++ b/README.md
@@ -0,0 +1,24 @@
+# scribble-text-lib
+
+This the source for the Racket packages: "scribble", "scribble-doc", "scribble-html-lib", "scribble-lib", "scribble-test", "scribble-text-lib".
+
+### Contributing
+
+Contribute to Racket by submitting a [pull request], reporting an
+[issue], joining the [development mailing list], or visiting the
+IRC or Slack channels.
+
+### License
+
+Racket, including these packages, is free software, see [LICENSE]
+for more details.
+
+By making a contribution, you are agreeing that your contribution
+is licensed under the [Apache 2.0] license and the [MIT] license.
+
+[MIT]: https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt
+[Apache 2.0]: https://www.apache.org/licenses/LICENSE-2.0.txt
+[pull request]: https://github.com/racket/scribble-text-lib/pulls
+[issue]: https://github.com/racket/scribble-text-lib/issues
+[development mailing list]: https://lists.racket-lang.org
+[LICENSE]: LICENSE
diff --git a/scribble-doc/LICENSE.txt b/scribble-doc/LICENSE.txt
deleted file mode 100644
index 1b827862..00000000
--- a/scribble-doc/LICENSE.txt
+++ /dev/null
@@ -1,11 +0,0 @@
-scribble-doc
-Copyright (c) 2010-2014 PLT Design Inc.
-
-This package is distributed under the GNU Lesser General Public
-License (LGPL). This means that you can link this package into proprietary
-applications, provided you follow the rules stated in the LGPL. You
-can also modify this package; if you distribute a modified version,
-you must distribute it under the terms of the LGPL, which in
-particular means that you must release the source code for the
-modified software. See http://www.gnu.org/copyleft/lesser.html
-for more information.
diff --git a/scribble-html-lib/LICENSE.txt b/scribble-html-lib/LICENSE.txt
deleted file mode 100644
index f31116b7..00000000
--- a/scribble-html-lib/LICENSE.txt
+++ /dev/null
@@ -1,11 +0,0 @@
-scribble-text-lib
-Copyright (c) 2010-2014 PLT Design Inc.
-
-This package is distributed under the GNU Lesser General Public
-License (LGPL). This means that you can link this package into proprietary
-applications, provided you follow the rules stated in the LGPL. You
-can also modify this package; if you distribute a modified version,
-you must distribute it under the terms of the LGPL, which in
-particular means that you must release the source code for the
-modified software. See http://www.gnu.org/copyleft/lesser.html
-for more information.
diff --git a/scribble-lib/LICENSE.txt b/scribble-lib/LICENSE.txt
deleted file mode 100644
index 1be10033..00000000
--- a/scribble-lib/LICENSE.txt
+++ /dev/null
@@ -1,11 +0,0 @@
-scribble-lib
-Copyright (c) 2010-2014 PLT Design Inc.
-
-This package is distributed under the GNU Lesser General Public
-License (LGPL). This means that you can link this package into proprietary
-applications, provided you follow the rules stated in the LGPL. You
-can also modify this package; if you distribute a modified version,
-you must distribute it under the terms of the LGPL, which in
-particular means that you must release the source code for the
-modified software. See http://www.gnu.org/copyleft/lesser.html
-for more information.
diff --git a/scribble-test/LICENSE.txt b/scribble-test/LICENSE.txt
deleted file mode 100644
index 614b7cd9..00000000
--- a/scribble-test/LICENSE.txt
+++ /dev/null
@@ -1,11 +0,0 @@
-scribble-test
-Copyright (c) 2010-2014 PLT Design Inc.
-
-This package is distributed under the GNU Lesser General Public
-License (LGPL). This means that you can link this package into proprietary
-applications, provided you follow the rules stated in the LGPL. You
-can also modify this package; if you distribute a modified version,
-you must distribute it under the terms of the LGPL, which in
-particular means that you must release the source code for the
-modified software. See http://www.gnu.org/copyleft/lesser.html
-for more information.
diff --git a/scribble-text-lib/LICENSE.txt b/scribble-text-lib/LICENSE.txt
deleted file mode 100644
index f31116b7..00000000
--- a/scribble-text-lib/LICENSE.txt
+++ /dev/null
@@ -1,11 +0,0 @@
-scribble-text-lib
-Copyright (c) 2010-2014 PLT Design Inc.
-
-This package is distributed under the GNU Lesser General Public
-License (LGPL). This means that you can link this package into proprietary
-applications, provided you follow the rules stated in the LGPL. You
-can also modify this package; if you distribute a modified version,
-you must distribute it under the terms of the LGPL, which in
-particular means that you must release the source code for the
-modified software. See http://www.gnu.org/copyleft/lesser.html
-for more information.
diff --git a/scribble/LICENSE.txt b/scribble/LICENSE.txt
deleted file mode 100644
index ba83018d..00000000
--- a/scribble/LICENSE.txt
+++ /dev/null
@@ -1,11 +0,0 @@
-scribble
-Copyright (c) 2010-2014 PLT Design Inc.
-
-This package is distributed under the GNU Lesser General Public
-License (LGPL). This means that you can link this package into proprietary
-applications, provided you follow the rules stated in the LGPL. You
-can also modify this package; if you distribute a modified version,
-you must distribute it under the terms of the LGPL, which in
-particular means that you must release the source code for the
-modified software. See http://www.gnu.org/copyleft/lesser.html
-for more information.
From e6d95a0367622a0bd7be610e4e99dc2936a4c5e1 Mon Sep 17 00:00:00 2001
From: Reuben Thomas <rrt@sc3d.org>
Date: Tue, 5 Nov 2019 15:00:17 +0000
Subject: [PATCH 05/17] scribble.tex, scribble/book.tex: fix trivial comment
typo (#217)
---
scribble-lib/scribble/book/style.tex | 2 +-
scribble-lib/scribble/scribble.tex | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/scribble-lib/scribble/book/style.tex b/scribble-lib/scribble/book/style.tex
index f70c1f21..d5bdbf66 100644
--- a/scribble-lib/scribble/book/style.tex
+++ b/scribble-lib/scribble/book/style.tex
@@ -38,7 +38,7 @@
\renewcommand{\Ssubsubsubsectiongrouperstar}[1]{\setcounter{GrouperTemp}{\value{subsubsection}}\Ssubsubsectionstar{#1}\setcounter{subsubsection}{\value{GrouperTemp}}}
\renewcommand{\Ssubsubsubsubsectiongrouperstar}[1]{\Ssubsubsubsubsectionstar{#1}}
-% To increments section numbers:
+% To increment section numbers:
\renewcommand{\Sincpart}{\stepcounter{part}}
\renewcommand{\Sincsection}{\stepcounter{chapter}}
\renewcommand{\Sincsubsection}{\stepcounter{section}}
diff --git a/scribble-lib/scribble/scribble.tex b/scribble-lib/scribble/scribble.tex
index 249fa4e7..67edccf8 100644
--- a/scribble-lib/scribble/scribble.tex
+++ b/scribble-lib/scribble/scribble.tex
@@ -372,7 +372,7 @@
% For hidden parts with an empty title:
\newcommand{\notitlesection}{\vspace{2ex}\phantomsection\noindent}
-% To increments section numbers:
+% To increment section numbers:
\newcommand{\Sincpart}{\stepcounter{part}}
\newcommand{\Sincsection}{\stepcounter{section}}
\newcommand{\Sincsubsection}{\stepcounter{subsection}}
From b67f265b93e74a2a525173449c6febc02c04d57a Mon Sep 17 00:00:00 2001
From: Reuben Thomas <rrt@sc3d.org>
Date: Tue, 5 Nov 2019 19:57:03 +0000
Subject: [PATCH 06/17] scribble.tex: fix comment typo (#218)
---
scribble-lib/scribble/scribble.tex | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/scribble-lib/scribble/scribble.tex b/scribble-lib/scribble/scribble.tex
index 67edccf8..dec3a0b4 100644
--- a/scribble-lib/scribble/scribble.tex
+++ b/scribble-lib/scribble/scribble.tex
@@ -112,7 +112,7 @@
\makeatletter
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\message{pltstabular is a modification of stabular}
-%% A renamed vsetion of:
+%% A renamed version of:
%% stabular.sty
%% Copyright 1998 Sigitas Tolu\v sis
%% VTeX Ltd., Akademijos 4, Vilnius, Lithuania
From fb7106bc50c91d7bf1975348f959c39b8f024f5b Mon Sep 17 00:00:00 2001
From: Reuben Thomas <rrt@sc3d.org>
Date: Tue, 12 Nov 2019 16:26:27 +0000
Subject: [PATCH 07/17] scribble-doc/scribblings/scribble/core.scrbl: fix typo
(#219)
---
scribble-doc/scribblings/scribble/core.scrbl | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/scribble-doc/scribblings/scribble/core.scrbl b/scribble-doc/scribblings/scribble/core.scrbl
index b17c5ab0..7da7e963 100644
--- a/scribble-doc/scribblings/scribble/core.scrbl
+++ b/scribble-doc/scribblings/scribble/core.scrbl
@@ -1958,7 +1958,7 @@ arguments to the element's command in Latex output.}
@defstruct[command-optional ([arguments (listof string?)])]{
Used as a @tech{style property} on a @racket[element] to add
- a optional arguments to the element's command in Latex output.
+ optional arguments to the element's command in Latex output.
@history[#:added "1.20"]
}
From 3c62d4cd5df898b321d192e286e4c14534b69a93 Mon Sep 17 00:00:00 2001
From: Jack Firth <jackhfirth@gmail.com>
Date: Wed, 9 Oct 2019 21:57:16 -0700
Subject: [PATCH 08/17] Langify scribble modules
---
scribble-lib/scribble/bnf.rkt | 209 +-
scribble-lib/scribble/comment-reader.rkt | 149 +-
scribble-lib/scribble/config.rkt | 7 +-
scribble-lib/scribble/racket.rkt | 2311 +++++++++++-----------
scribble-lib/scribble/search.rkt | 343 ++--
5 files changed, 1511 insertions(+), 1508 deletions(-)
diff --git a/scribble-lib/scribble/bnf.rkt b/scribble-lib/scribble/bnf.rkt
index a974716d..72d72e0e 100644
--- a/scribble-lib/scribble/bnf.rkt
+++ b/scribble-lib/scribble/bnf.rkt
@@ -1,121 +1,122 @@
-(module bnf racket
- (require scribble/decode
- (except-in scribble/struct
- element?)
- (only-in scribble/core
- content?
- element?
- make-style
- make-table-columns)
- )
+#lang racket
- (provide (contract-out
- [BNF (-> (cons/c (or/c block? content?)
- (non-empty-listof (or/c block? content?)))
- ...
- table?)]
- [BNF-etc element?]
- ;; operate on content
- [BNF-seq (-> content? ...
- (or/c element? ""))]
- [BNF-seq-lines (-> (listof content?) ...
- block?)]
- [BNF-alt (-> content? ...
- element?)]
- [BNF-alt/close (-> content? ...
- element?)]
- ;; operate on pre-content
- [BNF-group (-> pre-content? ...
- element?)]
- [nonterm (-> pre-content? ...
- element?)]
- [optional (-> pre-content? ...
- element?)]
- [kleenestar (-> pre-content? ...
- element?)]
- [kleeneplus (-> pre-content? ...
- element?)]
- [kleenerange (-> any/c any/c pre-content? ...
+(require scribble/decode
+ (except-in scribble/struct
+ element?)
+ (only-in scribble/core
+ content?
+ element?
+ make-style
+ make-table-columns)
+ )
+
+(provide (contract-out
+ [BNF (-> (cons/c (or/c block? content?)
+ (non-empty-listof (or/c block? content?)))
+ ...
+ table?)]
+ [BNF-etc element?]
+ ;; operate on content
+ [BNF-seq (-> content? ...
+ (or/c element? ""))]
+ [BNF-seq-lines (-> (listof content?) ...
+ block?)]
+ [BNF-alt (-> content? ...
+ element?)]
+ [BNF-alt/close (-> content? ...
element?)]
- ))
-
-
- (define spacer (make-element 'hspace (list " ")))
- (define equals (make-element 'tt (list spacer "::=" spacer)))
- (define alt (make-element 'tt (list spacer spacer "|" spacer spacer)))
-
- (define (as-flow i) (make-flow (list (if (block? i)
- i
- (make-paragraph (list i))))))
+ ;; operate on pre-content
+ [BNF-group (-> pre-content? ...
+ element?)]
+ [nonterm (-> pre-content? ...
+ element?)]
+ [optional (-> pre-content? ...
+ element?)]
+ [kleenestar (-> pre-content? ...
+ element?)]
+ [kleeneplus (-> pre-content? ...
+ element?)]
+ [kleenerange (-> any/c any/c pre-content? ...
+ element?)]
+ ))
- (define baseline (make-style #f '(baseline)))
+(define spacer (make-element 'hspace (list " ")))
+(define equals (make-element 'tt (list spacer "::=" spacer)))
+(define alt (make-element 'tt (list spacer spacer "|" spacer spacer)))
- (define (BNF . defns)
- (make-table
- (make-style #f
- (list
- (make-table-columns
- (list baseline baseline baseline baseline))))
- (apply
- append
- (map (match-lambda
- [(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))])
- defns))))
+(define (as-flow i) (make-flow (list (if (block? i)
+ i
+ (make-paragraph (list i))))))
- ;; interleave : (listof content?) element? -> element?
- (define (interleave l spacer)
- (make-element #f (cons (car l)
- (apply append
- (map (lambda (i)
- (list spacer i))
- (cdr l))))))
- (define (BNF-seq . l)
- (if (null? l)
- ""
- (interleave l spacer)))
+(define baseline (make-style #f '(baseline)))
- (define (BNF-seq-lines . l)
- (make-table #f (map (lambda (row) (list (as-flow (apply BNF-seq row))))
- l)))
+(define (BNF . defns)
+ (make-table
+ (make-style #f
+ (list
+ (make-table-columns
+ (list baseline baseline baseline baseline))))
+ (apply
+ append
+ (map (match-lambda
+ [(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))])
+ defns))))
- (define (BNF-alt . l)
- (interleave l alt))
+;; interleave : (listof content?) element? -> element?
+(define (interleave l spacer)
+ (make-element #f (cons (car l)
+ (apply append
+ (map (lambda (i)
+ (list spacer i))
+ (cdr l))))))
- (define (BNF-alt/close . l)
- (interleave l (make-element 'roman " | ")))
+(define (BNF-seq . l)
+ (if (null? l)
+ ""
+ (interleave l spacer)))
- (define BNF-etc (make-element 'roman "..."))
+(define (BNF-seq-lines . l)
+ (make-table #f (map (lambda (row) (list (as-flow (apply BNF-seq row))))
+ l)))
- (define (nonterm . s)
- (make-element 'roman (append (list 'lang)
- (list (make-element 'italic (decode-content s)))
- (list 'rang))))
+(define (BNF-alt . l)
+ (interleave l alt))
- (define (optional . s)
- (make-element #f (append (list (make-element 'roman "["))
- (decode-content s)
- (list (make-element 'roman "]")))))
+(define (BNF-alt/close . l)
+ (interleave l (make-element 'roman " | ")))
- (define (BNF-group . s)
- (make-element #f (append (list (make-element 'roman "{"))
- (list (apply BNF-seq (decode-content s)))
- (list (make-element 'roman "}")))))
+(define BNF-etc (make-element 'roman "..."))
- (define (kleenestar . s)
- (make-element #f (append (decode-content s) (list (make-element 'roman "*")))))
+(define (nonterm . s)
+ (make-element 'roman (append (list 'lang)
+ (list (make-element 'italic (decode-content s)))
+ (list 'rang))))
- (define (kleeneplus . s)
- (make-element #f (append (decode-content s) (list (make-element 'superscript (list "+"))))))
+(define (optional . s)
+ (make-element #f (append (list (make-element 'roman "["))
+ (decode-content s)
+ (list (make-element 'roman "]")))))
- (define (kleenerange a b . s)
- (make-element #f (append (decode-content s)
- (list (make-element 'roman
- (make-element 'superscript
- (list (format "{~a,~a}" a b)))))))))
+(define (BNF-group . s)
+ (make-element #f (append (list (make-element 'roman "{"))
+ (list (apply BNF-seq (decode-content s)))
+ (list (make-element 'roman "}")))))
+
+(define (kleenestar . s)
+ (make-element #f (append (decode-content s) (list (make-element 'roman "*")))))
+
+(define (kleeneplus . s)
+ (make-element #f (append (decode-content s) (list (make-element 'superscript (list "+"))))))
+
+(define (kleenerange a b . s)
+ (make-element #f (append (decode-content s)
+ (list (make-element 'roman
+ (make-element 'superscript
+ (list (format "{~a,~a}" a b))))))))
diff --git a/scribble-lib/scribble/comment-reader.rkt b/scribble-lib/scribble/comment-reader.rkt
index 049e8015..cf3435bb 100644
--- a/scribble-lib/scribble/comment-reader.rkt
+++ b/scribble-lib/scribble/comment-reader.rkt
@@ -1,83 +1,84 @@
-(module comment-reader scheme/base
- (require (only-in racket/port peeking-input-port))
+#lang scheme/base
- (provide (rename-out [*read read]
- [*read-syntax read-syntax])
- make-comment-readtable)
+(require (only-in racket/port peeking-input-port))
- (define unsyntaxer (make-parameter 'unsyntax))
+(provide (rename-out [*read read]
+ [*read-syntax read-syntax])
+ make-comment-readtable)
- (define (*read [inp (current-input-port)])
- (parameterize ([unsyntaxer (read-unsyntaxer inp)]
- [current-readtable (make-comment-readtable)])
- (read/recursive inp)))
+(define unsyntaxer (make-parameter 'unsyntax))
- (define (*read-syntax src [port (current-input-port)])
- (parameterize ([unsyntaxer (read-unsyntaxer port)]
- [current-readtable (make-comment-readtable)])
- (read-syntax/recursive src port)))
+(define (*read [inp (current-input-port)])
+ (parameterize ([unsyntaxer (read-unsyntaxer inp)]
+ [current-readtable (make-comment-readtable)])
+ (read/recursive inp)))
+
+(define (*read-syntax src [port (current-input-port)])
+ (parameterize ([unsyntaxer (read-unsyntaxer port)]
+ [current-readtable (make-comment-readtable)])
+ (read-syntax/recursive src port)))
- (define (read-unsyntaxer port)
- (let ([p (peeking-input-port port)])
- (if (eq? (read p) '#:escape-id)
- (begin (read port) (read port))
- 'unsyntax)))
+(define (read-unsyntaxer port)
+ (let ([p (peeking-input-port port)])
+ (if (eq? (read p) '#:escape-id)
+ (begin (read port) (read port))
+ 'unsyntax)))
- (define (make-comment-readtable #:readtable [rt (current-readtable)])
- (make-readtable rt
- #\; 'terminating-macro
- (case-lambda
- [(char port)
- (do-comment port (lambda () (read/recursive port #\@)))]
- [(char port src line col pos)
- (let ([v (do-comment port (lambda () (read-syntax/recursive src port #\@)))])
- (let-values ([(eline ecol epos) (port-next-location port)])
- (datum->syntax
- #f
- v
- (list src line col pos (and pos epos (- epos pos))))))])))
+(define (make-comment-readtable #:readtable [rt (current-readtable)])
+ (make-readtable rt
+ #\; 'terminating-macro
+ (case-lambda
+ [(char port)
+ (do-comment port (lambda () (read/recursive port #\@)))]
+ [(char port src line col pos)
+ (let ([v (do-comment port (lambda () (read-syntax/recursive src port #\@)))])
+ (let-values ([(eline ecol epos) (port-next-location port)])
+ (datum->syntax
+ #f
+ v
+ (list src line col pos (and pos epos (- epos pos))))))])))
- (define (do-comment port recur)
- (let loop ()
- (when (equal? #\; (peek-char port))
- (read-char port)
- (loop)))
- (when (equal? #\space (peek-char port))
- (read-char port))
- `(code:comment
- (,(unsyntaxer)
- (t
- ,@(append-strings
- (let loop ()
- (let ([c (read-char port)])
- (cond
- [(or (eof-object? c)
- (char=? c #\newline))
- null]
- [(char=? c #\@)
- (cons (recur) (loop))]
- [else
- (cons (string c)
- (loop))]))))))))
+(define (do-comment port recur)
+ (let loop ()
+ (when (equal? #\; (peek-char port))
+ (read-char port)
+ (loop)))
+ (when (equal? #\space (peek-char port))
+ (read-char port))
+ `(code:comment
+ (,(unsyntaxer)
+ (t
+ ,@(append-strings
+ (let loop ()
+ (let ([c (read-char port)])
+ (cond
+ [(or (eof-object? c)
+ (char=? c #\newline))
+ null]
+ [(char=? c #\@)
+ (cons (recur) (loop))]
+ [else
+ (cons (string c)
+ (loop))]))))))))
- (define (append-strings l)
- (let loop ([l l][s null])
- (cond
- [(null? l) (if (null? s)
- null
- (preserve-space (apply string-append (reverse s))))]
- [(string? (car l))
- (loop (cdr l) (cons (car l) s))]
- [else
- (append (loop null s)
- (cons
- (car l)
- (loop (cdr l) null)))])))
+(define (append-strings l)
+ (let loop ([l l][s null])
+ (cond
+ [(null? l) (if (null? s)
+ null
+ (preserve-space (apply string-append (reverse s))))]
+ [(string? (car l))
+ (loop (cdr l) (cons (car l) s))]
+ [else
+ (append (loop null s)
+ (cons
+ (car l)
+ (loop (cdr l) null)))])))
- (define (preserve-space s)
- (let ([m (regexp-match-positions #rx" +" s)])
- (if m
- (append (preserve-space (substring s 0 (caar m)))
- (list `(hspace ,(- (cdar m) (caar m))))
- (preserve-space (substring s (cdar m))))
- (list s)))))
+(define (preserve-space s)
+ (let ([m (regexp-match-positions #rx" +" s)])
+ (if m
+ (append (preserve-space (substring s 0 (caar m)))
+ (list `(hspace ,(- (cdar m) (caar m))))
+ (preserve-space (substring s (cdar m))))
+ (list s))))
diff --git a/scribble-lib/scribble/config.rkt b/scribble-lib/scribble/config.rkt
index 5822c588..c05a2dfc 100644
--- a/scribble-lib/scribble/config.rkt
+++ b/scribble-lib/scribble/config.rkt
@@ -1,6 +1,5 @@
+#lang mzscheme
-(module config mzscheme
+(provide value-color)
- (provide value-color)
-
- (define value-color "schemevalue"))
+(define value-color "schemevalue")
diff --git a/scribble-lib/scribble/racket.rkt b/scribble-lib/scribble/racket.rkt
index 55351b85..6ca2ee91 100644
--- a/scribble-lib/scribble/racket.rkt
+++ b/scribble-lib/scribble/racket.rkt
@@ -1,309 +1,310 @@
-(module racket racket/base
- (require "core.rkt"
- "basic.rkt"
- "search.rkt"
- "private/manual-sprop.rkt"
- "private/on-demand.rkt"
- "html-properties.rkt"
- file/convertible
- racket/extflonum
- (for-syntax racket/base))
+#lang racket/base
+
+(require "core.rkt"
+ "basic.rkt"
+ "search.rkt"
+ "private/manual-sprop.rkt"
+ "private/on-demand.rkt"
+ "html-properties.rkt"
+ file/convertible
+ racket/extflonum
+ (for-syntax racket/base))
- (provide define-code
- to-element
- to-element/no-color
- to-paragraph
- to-paragraph/prefix
- syntax-ize
- syntax-ize-hook
- current-keyword-list
- current-variable-list
- current-meta-list
+(provide define-code
+ to-element
+ to-element/no-color
+ to-paragraph
+ to-paragraph/prefix
+ syntax-ize
+ syntax-ize-hook
+ current-keyword-list
+ current-variable-list
+ current-meta-list
- input-color
- output-color
- input-background-color
- no-color
- reader-color
- result-color
- keyword-color
- comment-color
- paren-color
- meta-color
- value-color
- symbol-color
- variable-color
- opt-color
- error-color
- syntax-link-color
- value-link-color
- syntax-def-color
- value-def-color
- module-color
- module-link-color
- block-color
- highlighted-color
+ input-color
+ output-color
+ input-background-color
+ no-color
+ reader-color
+ result-color
+ keyword-color
+ comment-color
+ paren-color
+ meta-color
+ value-color
+ symbol-color
+ variable-color
+ opt-color
+ error-color
+ syntax-link-color
+ value-link-color
+ syntax-def-color
+ value-def-color
+ module-color
+ module-link-color
+ block-color
+ highlighted-color
- (struct-out var-id)
- (struct-out shaped-parens)
- (struct-out long-boolean)
- (struct-out just-context)
- (struct-out alternate-display)
- (struct-out literal-syntax)
- (for-syntax make-variable-id
- variable-id?
- make-element-id-transformer
- element-id-transformer?))
+ (struct-out var-id)
+ (struct-out shaped-parens)
+ (struct-out long-boolean)
+ (struct-out just-context)
+ (struct-out alternate-display)
+ (struct-out literal-syntax)
+ (for-syntax make-variable-id
+ variable-id?
+ make-element-id-transformer
+ element-id-transformer?))
- (define (make-racket-style s
- #:tt? [tt? #t]
- #:extras [extras null])
- (make-style s (if tt?
- (cons 'tt-chars
- (append extras
- scheme-properties))
- (append extras
- scheme-properties))))
+(define (make-racket-style s
+ #:tt? [tt? #t]
+ #:extras [extras null])
+ (make-style s (if tt?
+ (cons 'tt-chars
+ (append extras
+ scheme-properties))
+ (append extras
+ scheme-properties))))
- (define-on-demand output-color (make-racket-style "RktOut"))
- (define-on-demand input-color (make-racket-style "RktIn"))
- (define-on-demand input-background-color (make-racket-style "RktInBG"))
- (define-on-demand no-color (make-racket-style "RktPlain"))
- (define-on-demand reader-color (make-racket-style "RktRdr"))
- (define-on-demand result-color (make-racket-style "RktRes"))
- (define-on-demand keyword-color (make-racket-style "RktKw"))
- (define-on-demand comment-color (make-racket-style "RktCmt"))
- (define-on-demand paren-color (make-racket-style "RktPn"))
- (define-on-demand meta-color (make-racket-style "RktMeta"))
- (define-on-demand value-color (make-racket-style "RktVal"))
- (define-on-demand symbol-color (make-racket-style "RktSym"))
- (define-on-demand symbol-def-color (make-racket-style "RktSymDef"
- #:extras (list (attributes '((class . "RktSym"))))))
- (define-on-demand variable-color (make-racket-style "RktVar"))
- (define-on-demand opt-color (make-racket-style "RktOpt"))
- (define-on-demand error-color (make-racket-style "RktErr" #:tt? #f))
- (define-on-demand syntax-link-color (make-racket-style "RktStxLink"))
- (define-on-demand value-link-color (make-racket-style "RktValLink"))
- (define-on-demand syntax-def-color (make-racket-style "RktStxDef"
- #:extras (list (attributes '((class . "RktStxLink"))))))
- (define-on-demand value-def-color (make-racket-style "RktValDef"
- #:extras (list (attributes '((class . "RktValLink"))))))
- (define-on-demand module-color (make-racket-style "RktMod"))
- (define-on-demand module-link-color (make-racket-style "RktModLink"))
- (define-on-demand block-color (make-racket-style "RktBlk"))
- (define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f))
+(define-on-demand output-color (make-racket-style "RktOut"))
+(define-on-demand input-color (make-racket-style "RktIn"))
+(define-on-demand input-background-color (make-racket-style "RktInBG"))
+(define-on-demand no-color (make-racket-style "RktPlain"))
+(define-on-demand reader-color (make-racket-style "RktRdr"))
+(define-on-demand result-color (make-racket-style "RktRes"))
+(define-on-demand keyword-color (make-racket-style "RktKw"))
+(define-on-demand comment-color (make-racket-style "RktCmt"))
+(define-on-demand paren-color (make-racket-style "RktPn"))
+(define-on-demand meta-color (make-racket-style "RktMeta"))
+(define-on-demand value-color (make-racket-style "RktVal"))
+(define-on-demand symbol-color (make-racket-style "RktSym"))
+(define-on-demand symbol-def-color (make-racket-style "RktSymDef"
+ #:extras (list (attributes '((class . "RktSym"))))))
+(define-on-demand variable-color (make-racket-style "RktVar"))
+(define-on-demand opt-color (make-racket-style "RktOpt"))
+(define-on-demand error-color (make-racket-style "RktErr" #:tt? #f))
+(define-on-demand syntax-link-color (make-racket-style "RktStxLink"))
+(define-on-demand value-link-color (make-racket-style "RktValLink"))
+(define-on-demand syntax-def-color (make-racket-style "RktStxDef"
+ #:extras (list (attributes '((class . "RktStxLink"))))))
+(define-on-demand value-def-color (make-racket-style "RktValDef"
+ #:extras (list (attributes '((class . "RktValLink"))))))
+(define-on-demand module-color (make-racket-style "RktMod"))
+(define-on-demand module-link-color (make-racket-style "RktModLink"))
+(define-on-demand block-color (make-racket-style "RktBlk"))
+(define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f))
- (define current-keyword-list
- (make-parameter null))
- (define current-variable-list
- (make-parameter null))
- (define current-meta-list
- (make-parameter null))
+(define current-keyword-list
+ (make-parameter null))
+(define current-variable-list
+ (make-parameter null))
+(define current-meta-list
+ (make-parameter null))
- (define defined-names (make-hasheq))
+(define defined-names (make-hasheq))
- (define-struct (sized-element element) (length))
+(define-struct (sized-element element) (length))
- (define-struct (spaces element) (cnt))
+(define-struct (spaces element) (cnt))
- ;; We really don't want leading hypens (or minus signs) to
- ;; create a line break after the hyphen. For interior hyphens,
- ;; line breaking is usually fine.
- (define (nonbreak-leading-hyphens s)
- (let ([m (regexp-match-positions #rx"^-+" s)])
- (if m
- (if (= (cdar m) (string-length s))
- (make-element 'no-break s)
- (let ([len (add1 (cdar m))])
- (make-element #f (list (make-element 'no-break (substring s 0 len))
- (substring s len)))))
- s)))
+;; We really don't want leading hypens (or minus signs) to
+;; create a line break after the hyphen. For interior hyphens,
+;; line breaking is usually fine.
+(define (nonbreak-leading-hyphens s)
+ (let ([m (regexp-match-positions #rx"^-+" s)])
+ (if m
+ (if (= (cdar m) (string-length s))
+ (make-element 'no-break s)
+ (let ([len (add1 (cdar m))])
+ (make-element #f (list (make-element 'no-break (substring s 0 len))
+ (substring s len)))))
+ s)))
- (define (literalize-spaces i [leading? #f])
- (let ([m (regexp-match-positions #rx" +" i)])
- (if m
- (let ([cnt (- (cdar m) (caar m))])
- (make-spaces #f
- (list
- (literalize-spaces (substring i 0 (caar m)) #t)
- (hspace cnt)
- (literalize-spaces (substring i (cdar m))))
- cnt))
- (if leading?
- (nonbreak-leading-hyphens i)
- i))))
+(define (literalize-spaces i [leading? #f])
+ (let ([m (regexp-match-positions #rx" +" i)])
+ (if m
+ (let ([cnt (- (cdar m) (caar m))])
+ (make-spaces #f
+ (list
+ (literalize-spaces (substring i 0 (caar m)) #t)
+ (hspace cnt)
+ (literalize-spaces (substring i (cdar m))))
+ cnt))
+ (if leading?
+ (nonbreak-leading-hyphens i)
+ i))))
- (define line-breakable-space (make-element 'tt " "))
+(define line-breakable-space (make-element 'tt " "))
- ;; These caches intentionally record a key with the value.
- ;; That way, when the value is no longer used, the key
- ;; goes away, and the entry is gone.
+;; These caches intentionally record a key with the value.
+;; That way, when the value is no longer used, the key
+;; goes away, and the entry is gone.
- (define id-element-cache (make-weak-hash))
- (define element-cache (make-weak-hash))
+(define id-element-cache (make-weak-hash))
+(define element-cache (make-weak-hash))
- (define-struct (cached-delayed-element delayed-element) (cache-key))
- (define-struct (cached-element element) (cache-key))
+(define-struct (cached-delayed-element delayed-element) (cache-key))
+(define-struct (cached-element element) (cache-key))
- (define qq-ellipses (string->uninterned-symbol "..."))
+(define qq-ellipses (string->uninterned-symbol "..."))
- (define (make-id-element c s defn?)
- (let* ([key (and id-element-cache
- (let ([b (identifier-label-binding c)])
- (vector (syntax-e c)
- (module-path-index->taglet (caddr b))
- (cadddr b)
- (list-ref b 5)
- (syntax-property c 'display-string)
- defn?)))])
- (or (and key
- (let ([b (hash-ref id-element-cache key #f)])
- (and b
- (weak-box-value b))))
- (let ([e (make-cached-delayed-element
- (lambda (renderer sec ri)
- (let* ([tag (find-racket-tag sec ri c #f)])
- (if tag
- (let ([tag (intern-taglet tag)])
- (list
- (case (car tag)
- [(form)
- (make-link-element (if defn?
- syntax-def-color
- syntax-link-color)
- (nonbreak-leading-hyphens s)
- tag)]
- [else
- (make-link-element (if defn?
- value-def-color
- value-link-color)
- (nonbreak-leading-hyphens s)
- tag)])))
- (list
- (make-element "badlink"
- (make-element value-link-color s))))))
- (lambda () s)
- (lambda () s)
- (intern-taglet key))])
- (when key
- (hash-set! id-element-cache key (make-weak-box e)))
- e))))
+(define (make-id-element c s defn?)
+ (let* ([key (and id-element-cache
+ (let ([b (identifier-label-binding c)])
+ (vector (syntax-e c)
+ (module-path-index->taglet (caddr b))
+ (cadddr b)
+ (list-ref b 5)
+ (syntax-property c 'display-string)
+ defn?)))])
+ (or (and key
+ (let ([b (hash-ref id-element-cache key #f)])
+ (and b
+ (weak-box-value b))))
+ (let ([e (make-cached-delayed-element
+ (lambda (renderer sec ri)
+ (let* ([tag (find-racket-tag sec ri c #f)])
+ (if tag
+ (let ([tag (intern-taglet tag)])
+ (list
+ (case (car tag)
+ [(form)
+ (make-link-element (if defn?
+ syntax-def-color
+ syntax-link-color)
+ (nonbreak-leading-hyphens s)
+ tag)]
+ [else
+ (make-link-element (if defn?
+ value-def-color
+ value-link-color)
+ (nonbreak-leading-hyphens s)
+ tag)])))
+ (list
+ (make-element "badlink"
+ (make-element value-link-color s))))))
+ (lambda () s)
+ (lambda () s)
+ (intern-taglet key))])
+ (when key
+ (hash-set! id-element-cache key (make-weak-box e)))
+ e))))
- (define (make-element/cache style content)
- (if (and element-cache
- (string? content))
- (let ([key (vector style content)])
- (let ([b (hash-ref element-cache key #f)])
- (or (and b (weak-box-value b))
- (let ([e (make-cached-element style content key)])
- (hash-set! element-cache key (make-weak-box e))
- e))))
- (make-element style content)))
+(define (make-element/cache style content)
+ (if (and element-cache
+ (string? content))
+ (let ([key (vector style content)])
+ (let ([b (hash-ref element-cache key #f)])
+ (or (and b (weak-box-value b))
+ (let ([e (make-cached-element style content key)])
+ (hash-set! element-cache key (make-weak-box e))
+ e))))
+ (make-element style content)))
- (define (to-quoted obj expr? quote-depth out color? inc!)
- (if (and expr?
- (zero? quote-depth)
- (quotable? obj))
- (begin
- (out "'" (and color? value-color))
- (inc!)
- (add1 quote-depth))
- quote-depth))
+(define (to-quoted obj expr? quote-depth out color? inc!)
+ (if (and expr?
+ (zero? quote-depth)
+ (quotable? obj))
+ (begin
+ (out "'" (and color? value-color))
+ (inc!)
+ (add1 quote-depth))
+ quote-depth))
- (define (to-unquoted expr? quote-depth out color? inc!)
- (if (or (not expr?) (zero? quote-depth))
- quote-depth
- (begin
- (out "," (and color? meta-color))
- (inc!)
- (to-unquoted expr? (sub1 quote-depth) out color? inc!))))
+(define (to-unquoted expr? quote-depth out color? inc!)
+ (if (or (not expr?) (zero? quote-depth))
+ quote-depth
+ (begin
+ (out "," (and color? meta-color))
+ (inc!)
+ (to-unquoted expr? (sub1 quote-depth) out color? inc!))))
- (define iformat
- (case-lambda
- [(str val) (datum-intern-literal (format str val))]
- [(str . vals) (datum-intern-literal (apply format str vals))]))
+(define iformat
+ (case-lambda
+ [(str val) (datum-intern-literal (format str val))]
+ [(str . vals) (datum-intern-literal (apply format str vals))]))
- (define (typeset-atom c out color? quote-depth expr? escapes? defn?)
- (if (and (var-id? (syntax-e c))
- (zero? quote-depth))
- (out (iformat "~s" (let ([v (var-id-sym (syntax-e c))])
- (if (syntax? v)
- (syntax-e v)
- v)))
- variable-color)
- (let*-values ([(is-var?) (and (identifier? c)
- (memq (syntax-e c) (current-variable-list)))]
- [(s it? sub?)
- (let ([sc (syntax-e c)])
- (let ([s (cond
- [(syntax-property c 'display-string) => values]
- [(literal-syntax? sc) (iformat "~s" (literal-syntax-stx sc))]
- [(var-id? sc) (iformat "~s" (var-id-sym sc))]
- [(eq? sc #t)
- (if (equal? (syntax-span c) 5)
- "#true"
- "#t")]
- [(eq? sc #f)
- (if (equal? (syntax-span c) 6)
- "#false"
- "#f")]
- [(and (number? sc)
- (inexact? sc))
- (define s (iformat "~s" sc))
- (if (= (string-length s)
- (- (syntax-span c) 2))
- ;; There's no way to know whether the source used #i,
- ;; but it should be ok to include it:
- (string-append "#i" s)
- s)]
- [else (iformat "~s" sc)])])
- (if (and escapes?
- (symbol? sc)
- ((string-length s) . > . 1)
- (char=? (string-ref s 0) #\_)
- (not (or (identifier-label-binding c)
- is-var?)))
- (values (substring s 1) #t #f)
- (values s #f #f))))])
- (let ([quote-depth (if (and expr? (identifier? c) (not (eq? qq-ellipses (syntax-e c))))
- (let ([quote-depth
- (if (and (quote-depth . < . 2)
- (memq (syntax-e c) '(unquote unquote-splicing)))
- (to-unquoted expr? quote-depth out color? void)
- quote-depth)])
- (to-quoted c expr? quote-depth out color? void))
- quote-depth)])
- (if (or (element? (syntax-e c))
- (delayed-element? (syntax-e c))
- (part-relative-element? (syntax-e c))
- (convertible? (syntax-e c)))
- (out (syntax-e c) #f)
- (out (if (and (identifier? c)
- color?
- (quote-depth . <= . 0)
- (not (or it? is-var?)))
- (if (pair? (identifier-label-binding c))
- (make-id-element c s defn?)
- (let ([c (nonbreak-leading-hyphens s)])
- (if defn?
- (make-element symbol-def-color c)
- c)))
- (literalize-spaces s #t))
- (cond
- [(positive? quote-depth) value-color]
- [(let ([v (syntax-e c)])
- (or (number? v)
- (string? v)
- (bytes? v)
- (char? v)
- (regexp? v)
- (byte-regexp? v)
- (boolean? v)
- (extflonum? v)))
- value-color]
- [(identifier? c)
- (cond
+(define (typeset-atom c out color? quote-depth expr? escapes? defn?)
+ (if (and (var-id? (syntax-e c))
+ (zero? quote-depth))
+ (out (iformat "~s" (let ([v (var-id-sym (syntax-e c))])
+ (if (syntax? v)
+ (syntax-e v)
+ v)))
+ variable-color)
+ (let*-values ([(is-var?) (and (identifier? c)
+ (memq (syntax-e c) (current-variable-list)))]
+ [(s it? sub?)
+ (let ([sc (syntax-e c)])
+ (let ([s (cond
+ [(syntax-property c 'display-string) => values]
+ [(literal-syntax? sc) (iformat "~s" (literal-syntax-stx sc))]
+ [(var-id? sc) (iformat "~s" (var-id-sym sc))]
+ [(eq? sc #t)
+ (if (equal? (syntax-span c) 5)
+ "#true"
+ "#t")]
+ [(eq? sc #f)
+ (if (equal? (syntax-span c) 6)
+ "#false"
+ "#f")]
+ [(and (number? sc)
+ (inexact? sc))
+ (define s (iformat "~s" sc))
+ (if (= (string-length s)
+ (- (syntax-span c) 2))
+ ;; There's no way to know whether the source used #i,
+ ;; but it should be ok to include it:
+ (string-append "#i" s)
+ s)]
+ [else (iformat "~s" sc)])])
+ (if (and escapes?
+ (symbol? sc)
+ ((string-length s) . > . 1)
+ (char=? (string-ref s 0) #\_)
+ (not (or (identifier-label-binding c)
+ is-var?)))
+ (values (substring s 1) #t #f)
+ (values s #f #f))))])
+ (let ([quote-depth (if (and expr? (identifier? c) (not (eq? qq-ellipses (syntax-e c))))
+ (let ([quote-depth
+ (if (and (quote-depth . < . 2)
+ (memq (syntax-e c) '(unquote unquote-splicing)))
+ (to-unquoted expr? quote-depth out color? void)
+ quote-depth)])
+ (to-quoted c expr? quote-depth out color? void))
+ quote-depth)])
+ (if (or (element? (syntax-e c))
+ (delayed-element? (syntax-e c))
+ (part-relative-element? (syntax-e c))
+ (convertible? (syntax-e c)))
+ (out (syntax-e c) #f)
+ (out (if (and (identifier? c)
+ color?
+ (quote-depth . <= . 0)
+ (not (or it? is-var?)))
+ (if (pair? (identifier-label-binding c))
+ (make-id-element c s defn?)
+ (let ([c (nonbreak-leading-hyphens s)])
+ (if defn?
+ (make-element symbol-def-color c)
+ c)))
+ (literalize-spaces s #t))
+ (cond
+ [(positive? quote-depth) value-color]
+ [(let ([v (syntax-e c)])
+ (or (number? v)
+ (string? v)
+ (bytes? v)
+ (char? v)
+ (regexp? v)
+ (byte-regexp? v)
+ (boolean? v)
+ (extflonum? v)))
+ value-color]
+ [(identifier? c)
+ (cond
[is-var?
variable-color]
[(and (identifier? c)
@@ -314,41 +315,41 @@
meta-color]
[it? variable-color]
[else symbol-color])]
- [else paren-color])
- (string-length s)))))))
+ [else paren-color])
+ (string-length s)))))))
- (define omitable (make-style #f '(omitable)))
+(define omitable (make-style #f '(omitable)))
- (define (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
- (let* ([c (syntax-ize c 0 #:expr? expr?)]
- [content null]
- [docs null]
- [first (if escapes?
- (syntax-case c (code:line)
- [(code:line e . rest) #'e]
- [else c])
- c)]
- [init-col (or (syntax-column first) 0)]
- [src-col init-col]
- [inc-src-col (lambda () (set! src-col (add1 src-col)))]
- [dest-col 0]
- [highlight? #f]
- [col-map (make-hash)]
- [next-col-map (make-hash)]
- [line (or (syntax-line first) 0)])
- (define (finish-line!)
- (when multi-line?
- (set! docs (cons (make-paragraph omitable
- (if (null? content)
- (list (hspace 1))
- (reverse content)))
- docs))
- (set! content null)))
- (define out
- (case-lambda
- [(v cls)
- (out v cls (let sz-loop ([v v])
- (cond
+(define (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
+ (let* ([c (syntax-ize c 0 #:expr? expr?)]
+ [content null]
+ [docs null]
+ [first (if escapes?
+ (syntax-case c (code:line)
+ [(code:line e . rest) #'e]
+ [else c])
+ c)]
+ [init-col (or (syntax-column first) 0)]
+ [src-col init-col]
+ [inc-src-col (lambda () (set! src-col (add1 src-col)))]
+ [dest-col 0]
+ [highlight? #f]
+ [col-map (make-hash)]
+ [next-col-map (make-hash)]
+ [line (or (syntax-line first) 0)])
+ (define (finish-line!)
+ (when multi-line?
+ (set! docs (cons (make-paragraph omitable
+ (if (null? content)
+ (list (hspace 1))
+ (reverse content)))
+ docs))
+ (set! content null)))
+ (define out
+ (case-lambda
+ [(v cls)
+ (out v cls (let sz-loop ([v v])
+ (cond
[(string? v) (string-length v)]
[(list? v) (for/fold ([s 0]) ([v (in-list v)]) (+ s (sz-loop v)))]
[(sized-element? v) (sized-element-length v)]
@@ -363,9 +364,9 @@
(spaces-cnt v)
(sz-loop (caddr (element-content v))))]
[else 1])))]
- [(v cls len)
- (unless (equal? v "")
- (cond
+ [(v cls len)
+ (unless (equal? v "")
+ (cond
[(spaces? v)
(out (car (element-content v)) cls 0)
(out (cadr (element-content v)) #f 0)
@@ -387,235 +388,235 @@
v)))
content))
(set! dest-col (+ dest-col len))]))]))
- (define advance
- (case-lambda
- [(c init-line! srcless-step delta)
- (let ([c (+ delta (or (syntax-column c)
- (if srcless-step
- (+ src-col srcless-step)
- 0)))]
- [l (syntax-line c)])
- (let ([new-line? (and l (l . > . line))])
- (when new-line?
- (for ([i (in-range (- l line))])
- (out "\n" #f))
- (set! line l)
- (set! col-map next-col-map)
- (set! next-col-map (make-hash))
- (init-line!))
- (let ([d-col (let ([def-val (+ dest-col (- c src-col))])
- (if new-line?
- (hash-ref col-map c def-val)
- def-val))])
- (let ([amt (- d-col dest-col)])
- (when (positive? amt)
- (let ([old-dest-col dest-col])
- (out (if (and (= 1 amt) (not multi-line?))
- line-breakable-space ; allows a line break to replace the space
- (hspace amt))
- #f)
- (set! dest-col (+ old-dest-col amt))))))
- (set! src-col c)
- (hash-set! next-col-map src-col dest-col)))]
- [(c init-line! srcless-step) (advance c init-line! srcless-step 0)]
- [(c init-line!) (advance c init-line! #f 0)]))
- (define (for-each/i f l v)
- (unless (null? l)
- (f (car l) v)
- (for-each/i f (cdr l) 1)))
- (define (convert-infix c quote-depth expr?)
- (let ([l (syntax->list c)])
- (and l
- ((length l) . >= . 3)
- ((or (syntax-position (car l)) -inf.0)
- . > .
- (or (syntax-position (cadr l)) +inf.0))
- (let ([a (car l)])
- (let loop ([l (cdr l)]
- [prev null])
- (cond
- [(null? l) #f] ; couldn't unwind
- [else (let ([p2 (syntax-position (car l))])
- (if (and p2
- (p2 . > . (syntax-position a)))
- (datum->syntax c
- (append
- (reverse prev)
- (list
- (datum->syntax
- a
- (let ([val? (positive? quote-depth)])
- (make-sized-element
- (if val? value-color #f)
- (list
- (make-element/cache (if val? value-color paren-color) '". ")
- (typeset a #f "" "" "" (not val?) expr? escapes? defn? elem-wrap)
- (make-element/cache (if val? value-color paren-color) '" ."))
- (+ (syntax-span a) 4)))
- (list (syntax-source a)
- (syntax-line a)
- (- (syntax-column a) 2)
- (- (syntax-position a) 2)
- (+ (syntax-span a) 4))
- a))
- l)
- c
- c)
- (loop (cdr l)
- (cons (car l) prev))))]))))))
- (define (no-fancy-chars s)
+ (define advance
+ (case-lambda
+ [(c init-line! srcless-step delta)
+ (let ([c (+ delta (or (syntax-column c)
+ (if srcless-step
+ (+ src-col srcless-step)
+ 0)))]
+ [l (syntax-line c)])
+ (let ([new-line? (and l (l . > . line))])
+ (when new-line?
+ (for ([i (in-range (- l line))])
+ (out "\n" #f))
+ (set! line l)
+ (set! col-map next-col-map)
+ (set! next-col-map (make-hash))
+ (init-line!))
+ (let ([d-col (let ([def-val (+ dest-col (- c src-col))])
+ (if new-line?
+ (hash-ref col-map c def-val)
+ def-val))])
+ (let ([amt (- d-col dest-col)])
+ (when (positive? amt)
+ (let ([old-dest-col dest-col])
+ (out (if (and (= 1 amt) (not multi-line?))
+ line-breakable-space ; allows a line break to replace the space
+ (hspace amt))
+ #f)
+ (set! dest-col (+ old-dest-col amt))))))
+ (set! src-col c)
+ (hash-set! next-col-map src-col dest-col)))]
+ [(c init-line! srcless-step) (advance c init-line! srcless-step 0)]
+ [(c init-line!) (advance c init-line! #f 0)]))
+ (define (for-each/i f l v)
+ (unless (null? l)
+ (f (car l) v)
+ (for-each/i f (cdr l) 1)))
+ (define (convert-infix c quote-depth expr?)
+ (let ([l (syntax->list c)])
+ (and l
+ ((length l) . >= . 3)
+ ((or (syntax-position (car l)) -inf.0)
+ . > .
+ (or (syntax-position (cadr l)) +inf.0))
+ (let ([a (car l)])
+ (let loop ([l (cdr l)]
+ [prev null])
+ (cond
+ [(null? l) #f] ; couldn't unwind
+ [else (let ([p2 (syntax-position (car l))])
+ (if (and p2
+ (p2 . > . (syntax-position a)))
+ (datum->syntax c
+ (append
+ (reverse prev)
+ (list
+ (datum->syntax
+ a
+ (let ([val? (positive? quote-depth)])
+ (make-sized-element
+ (if val? value-color #f)
+ (list
+ (make-element/cache (if val? value-color paren-color) '". ")
+ (typeset a #f "" "" "" (not val?) expr? escapes? defn? elem-wrap)
+ (make-element/cache (if val? value-color paren-color) '" ."))
+ (+ (syntax-span a) 4)))
+ (list (syntax-source a)
+ (syntax-line a)
+ (- (syntax-column a) 2)
+ (- (syntax-position a) 2)
+ (+ (syntax-span a) 4))
+ a))
+ l)
+ c
+ c)
+ (loop (cdr l)
+ (cons (car l) prev))))]))))))
+ (define (no-fancy-chars s)
+ (cond
+ [(eq? s 'rsquo) "'"]
+ [else s]))
+ (define (loop init-line! quote-depth expr? no-cons?)
+ (lambda (c srcless-step)
(cond
- [(eq? s 'rsquo) "'"]
- [else s]))
- (define (loop init-line! quote-depth expr? no-cons?)
- (lambda (c srcless-step)
- (cond
- [(and escapes? (eq? 'code:blank (syntax-e c)))
- (advance c init-line! srcless-step)]
- [(and escapes?
- (pair? (syntax-e c))
- (eq? (syntax-e (car (syntax-e c))) 'code:comment))
- (let ([l (syntax->list c)])
- (unless (and l (= 2 (length l)))
- (raise-syntax-error
- #f
- "does not have a single sub-form"
- c)))
- (advance c init-line! srcless-step)
- (out ";" comment-color)
- (out 'nbsp comment-color)
- (let ([v (syntax->datum (cadr (syntax->list c)))])
- (if (paragraph? v)
- (map (lambda (v)
- (let ([v (no-fancy-chars v)])
- (if (or (string? v) (symbol? v))
- (out v comment-color)
- (out v #f))))
- (paragraph-content v))
- (out (no-fancy-chars v) comment-color)))]
- [(and escapes?
- (pair? (syntax-e c))
- (eq? (syntax-e (car (syntax-e c))) 'code:contract))
- (advance c init-line! srcless-step)
- (out "; " comment-color)
- (let* ([l (cdr (syntax->list c))]
- [s-col (or (syntax-column (car l)) src-col)])
- (set! src-col s-col)
- (for-each/i (loop (lambda ()
- (set! src-col s-col)
- (set! dest-col 0)
- (out "; " comment-color))
- 0
- expr?
- #f)
- l
- #f))]
- [(and escapes?
- (pair? (syntax-e c))
- (eq? (syntax-e (car (syntax-e c))) 'code:line))
- (let ([l (cdr (syntax->list c))])
- (for-each/i (loop init-line! quote-depth expr? #f)
- l
- #f))]
- [(and escapes?
- (pair? (syntax-e c))
- (eq? (syntax-e (car (syntax-e c))) 'code:hilite))
- (let ([l (syntax->list c)]
- [h? highlight?])
- (unless (and l (= 2 (length l)))
- (error "bad code:redex: ~.s" (syntax->datum c)))
- (advance c init-line! srcless-step)
- (set! src-col (syntax-column (cadr l)))
- (hash-set! next-col-map src-col dest-col)
- (set! highlight? #t)
- ((loop init-line! quote-depth expr? #f) (cadr l) #f)
- (set! highlight? h?)
- (set! src-col (add1 src-col)))]
- [(and escapes?
- (pair? (syntax-e c))
- (eq? (syntax-e (car (syntax-e c))) 'code:quote))
- (advance c init-line! srcless-step)
- (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
- (out "(" (if (positive? quote-depth) value-color paren-color))
- (set! src-col (+ src-col 1))
- (hash-set! next-col-map src-col dest-col)
- ((loop init-line! quote-depth expr? #f)
- (datum->syntax #'here 'quote (car (syntax-e c)))
- #f)
- (for-each/i (loop init-line! (add1 quote-depth) expr? #f)
- (cdr (syntax->list c))
- 1)
- (out ")" (if (positive? quote-depth) value-color paren-color))
- (set! src-col (+ src-col 1))
- #;
- (hash-set! next-col-map src-col dest-col))]
- [(and (pair? (syntax-e c))
- (memq (syntax-e (car (syntax-e c)))
- '(quote quasiquote unquote unquote-splicing
- quasisyntax syntax unsyntax unsyntax-splicing))
- (let ([v (syntax->list c)])
- (and v (= 2 (length v))))
- (or (not expr?)
- (positive? quote-depth)
- (quotable? c)))
- (advance c init-line! srcless-step)
- (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
- (let-values ([(str quote-delta)
- (case (syntax-e (car (syntax-e c)))
- [(quote) (values "'" +inf.0)]
- [(unquote) (values "," -1)]
- [(unquote-splicing) (values ",@" -1)]
- [(quasiquote) (values "`" +1)]
- [(syntax) (values "#'" 0)]
- [(quasisyntax) (values "#`" 0)]
- [(unsyntax) (values "#," 0)]
- [(unsyntax-splicing) (values "#,@" 0)])])
- (out str (if (positive? (+ quote-depth quote-delta))
- value-color
- reader-color))
- (let ([i (cadr (syntax->list c))])
- (set! src-col (or (syntax-column i) src-col))
- (hash-set! next-col-map src-col dest-col)
- ((loop init-line! (max 0 (+ quote-depth quote-delta)) expr? #f) i #f))))]
- [(and (pair? (syntax-e c))
- (or (not expr?)
- (positive? quote-depth)
- (quotable? c))
- (convert-infix c quote-depth expr?))
- => (lambda (converted)
- ((loop init-line! quote-depth expr? #f) converted srcless-step))]
- [(or (pair? (syntax-e c))
- (mpair? (syntax-e c))
- (forced-pair? (syntax-e c))
- (null? (syntax-e c))
- (vector? (syntax-e c))
- (and (struct? (syntax-e c))
- (prefab-struct-key (syntax-e c)))
- (struct-proxy? (syntax-e c)))
- (let* ([sh (or (syntax-property c 'paren-shape)
- (if (and (mpair? (syntax-e c))
- (not (and expr? (zero? quote-depth))))
- #\{
- #\())]
- [quote-depth (if (and (not expr?)
- (zero? quote-depth)
- (or (vector? (syntax-e c))
- (struct? (syntax-e c))))
- 1
- quote-depth)]
- [p-color (if (positive? quote-depth)
- value-color
- (if (eq? sh #\?)
- opt-color
- paren-color))])
- (advance c init-line! srcless-step)
- (let ([quote-depth (if (struct-proxy? (syntax-e c))
- quote-depth
- (to-quoted c expr? quote-depth out color? inc-src-col))])
- (when (and expr? (zero? quote-depth))
- (out "(" p-color)
- (unless no-cons?
- (out (let ([s (cond
+ [(and escapes? (eq? 'code:blank (syntax-e c)))
+ (advance c init-line! srcless-step)]
+ [(and escapes?
+ (pair? (syntax-e c))
+ (eq? (syntax-e (car (syntax-e c))) 'code:comment))
+ (let ([l (syntax->list c)])
+ (unless (and l (= 2 (length l)))
+ (raise-syntax-error
+ #f
+ "does not have a single sub-form"
+ c)))
+ (advance c init-line! srcless-step)
+ (out ";" comment-color)
+ (out 'nbsp comment-color)
+ (let ([v (syntax->datum (cadr (syntax->list c)))])
+ (if (paragraph? v)
+ (map (lambda (v)
+ (let ([v (no-fancy-chars v)])
+ (if (or (string? v) (symbol? v))
+ (out v comment-color)
+ (out v #f))))
+ (paragraph-content v))
+ (out (no-fancy-chars v) comment-color)))]
+ [(and escapes?
+ (pair? (syntax-e c))
+ (eq? (syntax-e (car (syntax-e c))) 'code:contract))
+ (advance c init-line! srcless-step)
+ (out "; " comment-color)
+ (let* ([l (cdr (syntax->list c))]
+ [s-col (or (syntax-column (car l)) src-col)])
+ (set! src-col s-col)
+ (for-each/i (loop (lambda ()
+ (set! src-col s-col)
+ (set! dest-col 0)
+ (out "; " comment-color))
+ 0
+ expr?
+ #f)
+ l
+ #f))]
+ [(and escapes?
+ (pair? (syntax-e c))
+ (eq? (syntax-e (car (syntax-e c))) 'code:line))
+ (let ([l (cdr (syntax->list c))])
+ (for-each/i (loop init-line! quote-depth expr? #f)
+ l
+ #f))]
+ [(and escapes?
+ (pair? (syntax-e c))
+ (eq? (syntax-e (car (syntax-e c))) 'code:hilite))
+ (let ([l (syntax->list c)]
+ [h? highlight?])
+ (unless (and l (= 2 (length l)))
+ (error "bad code:redex: ~.s" (syntax->datum c)))
+ (advance c init-line! srcless-step)
+ (set! src-col (syntax-column (cadr l)))
+ (hash-set! next-col-map src-col dest-col)
+ (set! highlight? #t)
+ ((loop init-line! quote-depth expr? #f) (cadr l) #f)
+ (set! highlight? h?)
+ (set! src-col (add1 src-col)))]
+ [(and escapes?
+ (pair? (syntax-e c))
+ (eq? (syntax-e (car (syntax-e c))) 'code:quote))
+ (advance c init-line! srcless-step)
+ (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
+ (out "(" (if (positive? quote-depth) value-color paren-color))
+ (set! src-col (+ src-col 1))
+ (hash-set! next-col-map src-col dest-col)
+ ((loop init-line! quote-depth expr? #f)
+ (datum->syntax #'here 'quote (car (syntax-e c)))
+ #f)
+ (for-each/i (loop init-line! (add1 quote-depth) expr? #f)
+ (cdr (syntax->list c))
+ 1)
+ (out ")" (if (positive? quote-depth) value-color paren-color))
+ (set! src-col (+ src-col 1))
+ #;
+ (hash-set! next-col-map src-col dest-col))]
+ [(and (pair? (syntax-e c))
+ (memq (syntax-e (car (syntax-e c)))
+ '(quote quasiquote unquote unquote-splicing
+ quasisyntax syntax unsyntax unsyntax-splicing))
+ (let ([v (syntax->list c)])
+ (and v (= 2 (length v))))
+ (or (not expr?)
+ (positive? quote-depth)
+ (quotable? c)))
+ (advance c init-line! srcless-step)
+ (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
+ (let-values ([(str quote-delta)
+ (case (syntax-e (car (syntax-e c)))
+ [(quote) (values "'" +inf.0)]
+ [(unquote) (values "," -1)]
+ [(unquote-splicing) (values ",@" -1)]
+ [(quasiquote) (values "`" +1)]
+ [(syntax) (values "#'" 0)]
+ [(quasisyntax) (values "#`" 0)]
+ [(unsyntax) (values "#," 0)]
+ [(unsyntax-splicing) (values "#,@" 0)])])
+ (out str (if (positive? (+ quote-depth quote-delta))
+ value-color
+ reader-color))
+ (let ([i (cadr (syntax->list c))])
+ (set! src-col (or (syntax-column i) src-col))
+ (hash-set! next-col-map src-col dest-col)
+ ((loop init-line! (max 0 (+ quote-depth quote-delta)) expr? #f) i #f))))]
+ [(and (pair? (syntax-e c))
+ (or (not expr?)
+ (positive? quote-depth)
+ (quotable? c))
+ (convert-infix c quote-depth expr?))
+ => (lambda (converted)
+ ((loop init-line! quote-depth expr? #f) converted srcless-step))]
+ [(or (pair? (syntax-e c))
+ (mpair? (syntax-e c))
+ (forced-pair? (syntax-e c))
+ (null? (syntax-e c))
+ (vector? (syntax-e c))
+ (and (struct? (syntax-e c))
+ (prefab-struct-key (syntax-e c)))
+ (struct-proxy? (syntax-e c)))
+ (let* ([sh (or (syntax-property c 'paren-shape)
+ (if (and (mpair? (syntax-e c))
+ (not (and expr? (zero? quote-depth))))
+ #\{
+ #\())]
+ [quote-depth (if (and (not expr?)
+ (zero? quote-depth)
+ (or (vector? (syntax-e c))
+ (struct? (syntax-e c))))
+ 1
+ quote-depth)]
+ [p-color (if (positive? quote-depth)
+ value-color
+ (if (eq? sh #\?)
+ opt-color
+ paren-color))])
+ (advance c init-line! srcless-step)
+ (let ([quote-depth (if (struct-proxy? (syntax-e c))
+ quote-depth
+ (to-quoted c expr? quote-depth out color? inc-src-col))])
+ (when (and expr? (zero? quote-depth))
+ (out "(" p-color)
+ (unless no-cons?
+ (out (let ([s (cond
[(pair? (syntax-e c))
(if (syntax->list c)
"list"
@@ -631,36 +632,36 @@
(if (struct-proxy? (syntax-e c))
(syntax-e (struct-proxy-name (syntax-e c)))
(object-name (syntax-e c))))])])
- (set! src-col (+ src-col (if (struct-proxy? (syntax-e c))
- 1
- (string-length s))))
- s)
- symbol-color)
- (unless (and (struct-proxy? (syntax-e c))
- (null? (struct-proxy-content (syntax-e c))))
- (out " " #f))))
- (when (vector? (syntax-e c))
- (unless (and expr? (zero? quote-depth))
- (let ([vec (syntax-e c)])
- (out "#" p-color)
- (if (zero? (vector-length vec))
- (set! src-col (+ src-col (- (syntax-span c) 2)))
- (set! src-col (+ src-col (- (syntax-column (vector-ref vec 0))
- (syntax-column c)
- 1)))))))
- (when (struct? (syntax-e c))
- (unless (and expr? (zero? quote-depth))
- (out "#s" p-color)
- (set! src-col (+ src-col 2))))
- (unless (and expr? (zero? quote-depth))
- (out (case sh
- [(#\[ #\?) "["]
- [(#\{) "{"]
- [else "("])
- p-color))
- (set! src-col (+ src-col 1))
- (hash-set! next-col-map src-col dest-col)
- (let lloop ([l (cond
+ (set! src-col (+ src-col (if (struct-proxy? (syntax-e c))
+ 1
+ (string-length s))))
+ s)
+ symbol-color)
+ (unless (and (struct-proxy? (syntax-e c))
+ (null? (struct-proxy-content (syntax-e c))))
+ (out " " #f))))
+ (when (vector? (syntax-e c))
+ (unless (and expr? (zero? quote-depth))
+ (let ([vec (syntax-e c)])
+ (out "#" p-color)
+ (if (zero? (vector-length vec))
+ (set! src-col (+ src-col (- (syntax-span c) 2)))
+ (set! src-col (+ src-col (- (syntax-column (vector-ref vec 0))
+ (syntax-column c)
+ 1)))))))
+ (when (struct? (syntax-e c))
+ (unless (and expr? (zero? quote-depth))
+ (out "#s" p-color)
+ (set! src-col (+ src-col 2))))
+ (unless (and expr? (zero? quote-depth))
+ (out (case sh
+ [(#\[ #\?) "["]
+ [(#\{) "{"]
+ [else "("])
+ p-color))
+ (set! src-col (+ src-col 1))
+ (hash-set! next-col-map src-col dest-col)
+ (let lloop ([l (cond
[(vector? (syntax-e c))
(vector->short-list (syntax-e c) syntax-e)]
[(struct? (syntax-e c))
@@ -693,13 +694,13 @@
[(mpair? (syntax-e c))
(syntax-e c)]
[else c])]
- [first-expr? (and expr?
- (or (zero? quote-depth)
- (not (struct-proxy? (syntax-e c))))
- (not no-cons?))]
- [dotted? #f]
- [srcless-step #f])
- (cond
+ [first-expr? (and expr?
+ (or (zero? quote-depth)
+ (not (struct-proxy? (syntax-e c))))
+ (not no-cons?))]
+ [dotted? #f]
+ [srcless-step #f])
+ (cond
[(and (syntax? l)
(pair? (syntax-e l))
(not dotted?)
@@ -734,494 +735,494 @@
((loop init-line! quote-depth first-expr? #f) l (if (and expr? (zero? quote-depth))
srcless-step
#f))]))
- (out (case sh
- [(#\[ #\?) "]"]
- [(#\{) "}"]
- [else ")"])
- p-color)
- (set! src-col (+ src-col 1))))]
- [(box? (syntax-e c))
- (advance c init-line! srcless-step)
- (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
- (if (and expr? (zero? quote-depth))
- (begin
- (out "(" paren-color)
- (out "box" symbol-color)
- (out " " #f)
- (set! src-col (+ src-col 5)))
- (begin
- (out "#&" value-color)
- (set! src-col (+ src-col 2))))
- (hash-set! next-col-map src-col dest-col)
- ((loop init-line! (if expr? quote-depth +inf.0) expr? #f) (unbox (syntax-e c)) #f)
- (when (and expr? (zero? quote-depth))
- (out ")" paren-color)))]
- [(hash? (syntax-e c))
- (advance c init-line! srcless-step)
- (let ([equal-table? (hash-equal? (syntax-e c))]
- [eqv-table? (hash-eqv? (syntax-e c))]
- [quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
- (unless (and expr? (zero? quote-depth))
- (out (if equal-table?
- "#hash"
- (if eqv-table?
- "#hasheqv"
- "#hasheq"))
- value-color))
- (let ([delta (+ 5 (if equal-table? 0 (if eqv-table? 3 2))
- (if (and expr? (zero? quote-depth)) 1 0))]
- [orig-col src-col])
- (set! src-col (+ src-col delta))
- (hash-set! next-col-map src-col dest-col)
- ((loop init-line! (if expr? quote-depth +inf.0) expr? (and expr? (zero? quote-depth)))
- (let*-values ([(l) (sort (hash-map (syntax-e c) cons)
- (lambda (a b)
- (< (or (syntax-position (cdr a)) -inf.0)
- (or (syntax-position (cdr b)) -inf.0))))]
- [(sep cap) (if (and expr? (zero? quote-depth))
- (values 1 0)
- (values 3 1))]
- [(col0) (+ (syntax-column c) delta cap 1)]
- [(l2 pos line) (for/fold ([l2 null][col col0][line (syntax-line c)])
- ([p (in-list l)])
- (let* ([tentative (syntax-ize (car p) 0
- #:expr? (and expr? (zero? quote-depth)))]
- [width (syntax-span tentative)]
- [col (if (= line (syntax-line (cdr p)))
- col
- col0)])
- (let ([key
- (let ([e (syntax-ize (car p)
- (max 0 (- (syntax-column (cdr p))
- width
- sep))
- (syntax-line (cdr p))
- #:expr? (and expr? (zero? quote-depth)))])
- (if ((syntax-column e) . <= . col)
- e
- (datum->syntax #f
- (syntax-e e)
- (vector (syntax-source e)
- (syntax-line e)
- col
- (syntax-position e)
- (+ (syntax-span e) (- (syntax-column e) col))))))])
- (let ([elem
- (datum->syntax
- #f
- (make-forced-pair key (cdr p))
- (vector 'here
- (syntax-line (cdr p))
- (max 0 (- (syntax-column key) cap))
- (max 1 (- (syntax-position key) cap))
- (+ (syntax-span (cdr p)) (syntax-span key) sep cap cap)))])
- (values (cons elem l2)
- (+ (syntax-column elem) (syntax-span elem) 2)
- (syntax-line elem))))))])
- (if (and expr? (zero? quote-depth))
- ;; constructed:
- (let ([l (apply append
- (map (lambda (p)
- (let ([p (syntax-e p)])
- (list (forced-pair-car p)
- (forced-pair-cdr p))))
- (reverse l2)))])
- (datum->syntax
- #f
- (cons (let ([s (if equal-table?
- 'hash
- (if eqv-table?
- 'hasheqv
- 'hasheq))])
- (datum->syntax #f
- s
- (vector (syntax-source c)
- (syntax-line c)
- (+ (syntax-column c) 1)
- (+ (syntax-position c) 1)
- (string-length (symbol->string s)))))
- l)
- c))
- ;; quoted:
- (datum->syntax #f (reverse l2) (vector (syntax-source c)
- (syntax-line c)
- (+ (syntax-column c) delta)
- (+ (syntax-position c) delta)
- (max 1 (- (syntax-span c) delta))))))
- #f)
- (set! src-col (+ orig-col (syntax-span c)))))]
- [(graph-reference? (syntax-e c))
- (advance c init-line! srcless-step)
- (out (iformat "#~a#" (unbox (graph-reference-bx (syntax-e c))))
- (if (positive? quote-depth)
- value-color
- paren-color))
- (set! src-col (+ src-col (syntax-span c)))]
- [(graph-defn? (syntax-e c))
- (advance c init-line! srcless-step)
- (let ([bx (graph-defn-bx (syntax-e c))])
- (out (iformat "#~a=" (unbox bx))
- (if (positive? quote-depth)
- value-color
- paren-color))
- (set! src-col (+ src-col 3))
- ((loop init-line! quote-depth expr? #f) (graph-defn-r (syntax-e c)) #f))]
- [(and (keyword? (syntax-e c)) expr?)
- (advance c init-line! srcless-step)
- (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
- (typeset-atom c out color? quote-depth expr? escapes? defn?)
- (set! src-col (+ src-col (or (syntax-span c) 1))))]
- [else
- (advance c init-line! srcless-step)
- (typeset-atom c out color? quote-depth expr? escapes? defn?)
- (set! src-col (+ src-col (or (syntax-span c) 1)))
- #;
- (hash-set! next-col-map src-col dest-col)])))
- (out prefix1 #f)
- (set! dest-col 0)
- (hash-set! next-col-map init-col dest-col)
- ((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0 expr? #f) c #f)
- (if (list? suffix)
- (map (lambda (sfx)
- (finish-line!)
- (out sfx #f))
- suffix)
- (out suffix #f))
- (unless (null? content)
- (finish-line!))
- (if multi-line?
- (if (= 1 (length docs))
- (car docs)
- (make-table block-color (map list (reverse docs))))
- (make-sized-element #f (reverse content) dest-col))))
+ (out (case sh
+ [(#\[ #\?) "]"]
+ [(#\{) "}"]
+ [else ")"])
+ p-color)
+ (set! src-col (+ src-col 1))))]
+ [(box? (syntax-e c))
+ (advance c init-line! srcless-step)
+ (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
+ (if (and expr? (zero? quote-depth))
+ (begin
+ (out "(" paren-color)
+ (out "box" symbol-color)
+ (out " " #f)
+ (set! src-col (+ src-col 5)))
+ (begin
+ (out "#&" value-color)
+ (set! src-col (+ src-col 2))))
+ (hash-set! next-col-map src-col dest-col)
+ ((loop init-line! (if expr? quote-depth +inf.0) expr? #f) (unbox (syntax-e c)) #f)
+ (when (and expr? (zero? quote-depth))
+ (out ")" paren-color)))]
+ [(hash? (syntax-e c))
+ (advance c init-line! srcless-step)
+ (let ([equal-table? (hash-equal? (syntax-e c))]
+ [eqv-table? (hash-eqv? (syntax-e c))]
+ [quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
+ (unless (and expr? (zero? quote-depth))
+ (out (if equal-table?
+ "#hash"
+ (if eqv-table?
+ "#hasheqv"
+ "#hasheq"))
+ value-color))
+ (let ([delta (+ 5 (if equal-table? 0 (if eqv-table? 3 2))
+ (if (and expr? (zero? quote-depth)) 1 0))]
+ [orig-col src-col])
+ (set! src-col (+ src-col delta))
+ (hash-set! next-col-map src-col dest-col)
+ ((loop init-line! (if expr? quote-depth +inf.0) expr? (and expr? (zero? quote-depth)))
+ (let*-values ([(l) (sort (hash-map (syntax-e c) cons)
+ (lambda (a b)
+ (< (or (syntax-position (cdr a)) -inf.0)
+ (or (syntax-position (cdr b)) -inf.0))))]
+ [(sep cap) (if (and expr? (zero? quote-depth))
+ (values 1 0)
+ (values 3 1))]
+ [(col0) (+ (syntax-column c) delta cap 1)]
+ [(l2 pos line) (for/fold ([l2 null][col col0][line (syntax-line c)])
+ ([p (in-list l)])
+ (let* ([tentative (syntax-ize (car p) 0
+ #:expr? (and expr? (zero? quote-depth)))]
+ [width (syntax-span tentative)]
+ [col (if (= line (syntax-line (cdr p)))
+ col
+ col0)])
+ (let ([key
+ (let ([e (syntax-ize (car p)
+ (max 0 (- (syntax-column (cdr p))
+ width
+ sep))
+ (syntax-line (cdr p))
+ #:expr? (and expr? (zero? quote-depth)))])
+ (if ((syntax-column e) . <= . col)
+ e
+ (datum->syntax #f
+ (syntax-e e)
+ (vector (syntax-source e)
+ (syntax-line e)
+ col
+ (syntax-position e)
+ (+ (syntax-span e) (- (syntax-column e) col))))))])
+ (let ([elem
+ (datum->syntax
+ #f
+ (make-forced-pair key (cdr p))
+ (vector 'here
+ (syntax-line (cdr p))
+ (max 0 (- (syntax-column key) cap))
+ (max 1 (- (syntax-position key) cap))
+ (+ (syntax-span (cdr p)) (syntax-span key) sep cap cap)))])
+ (values (cons elem l2)
+ (+ (syntax-column elem) (syntax-span elem) 2)
+ (syntax-line elem))))))])
+ (if (and expr? (zero? quote-depth))
+ ;; constructed:
+ (let ([l (apply append
+ (map (lambda (p)
+ (let ([p (syntax-e p)])
+ (list (forced-pair-car p)
+ (forced-pair-cdr p))))
+ (reverse l2)))])
+ (datum->syntax
+ #f
+ (cons (let ([s (if equal-table?
+ 'hash
+ (if eqv-table?
+ 'hasheqv
+ 'hasheq))])
+ (datum->syntax #f
+ s
+ (vector (syntax-source c)
+ (syntax-line c)
+ (+ (syntax-column c) 1)
+ (+ (syntax-position c) 1)
+ (string-length (symbol->string s)))))
+ l)
+ c))
+ ;; quoted:
+ (datum->syntax #f (reverse l2) (vector (syntax-source c)
+ (syntax-line c)
+ (+ (syntax-column c) delta)
+ (+ (syntax-position c) delta)
+ (max 1 (- (syntax-span c) delta))))))
+ #f)
+ (set! src-col (+ orig-col (syntax-span c)))))]
+ [(graph-reference? (syntax-e c))
+ (advance c init-line! srcless-step)
+ (out (iformat "#~a#" (unbox (graph-reference-bx (syntax-e c))))
+ (if (positive? quote-depth)
+ value-color
+ paren-color))
+ (set! src-col (+ src-col (syntax-span c)))]
+ [(graph-defn? (syntax-e c))
+ (advance c init-line! srcless-step)
+ (let ([bx (graph-defn-bx (syntax-e c))])
+ (out (iformat "#~a=" (unbox bx))
+ (if (positive? quote-depth)
+ value-color
+ paren-color))
+ (set! src-col (+ src-col 3))
+ ((loop init-line! quote-depth expr? #f) (graph-defn-r (syntax-e c)) #f))]
+ [(and (keyword? (syntax-e c)) expr?)
+ (advance c init-line! srcless-step)
+ (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)])
+ (typeset-atom c out color? quote-depth expr? escapes? defn?)
+ (set! src-col (+ src-col (or (syntax-span c) 1))))]
+ [else
+ (advance c init-line! srcless-step)
+ (typeset-atom c out color? quote-depth expr? escapes? defn?)
+ (set! src-col (+ src-col (or (syntax-span c) 1)))
+ #;
+ (hash-set! next-col-map src-col dest-col)])))
+ (out prefix1 #f)
+ (set! dest-col 0)
+ (hash-set! next-col-map init-col dest-col)
+ ((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0 expr? #f) c #f)
+ (if (list? suffix)
+ (map (lambda (sfx)
+ (finish-line!)
+ (out sfx #f))
+ suffix)
+ (out suffix #f))
+ (unless (null? content)
+ (finish-line!))
+ (if multi-line?
+ (if (= 1 (length docs))
+ (car docs)
+ (make-table block-color (map list (reverse docs))))
+ (make-sized-element #f (reverse content) dest-col))))
- (define (typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
- (let* ([c (syntax-ize c 0 #:expr? expr?)]
- [s (syntax-e c)])
- (if (or multi-line?
- (and escapes? (eq? 'code:blank s))
- (pair? s)
- (mpair? s)
- (vector? s)
- (struct? s)
- (box? s)
- (null? s)
- (hash? s)
- (graph-defn? s)
- (graph-reference? s)
- (struct-proxy? s)
- (and expr? (or (identifier? c)
- (keyword? (syntax-e c)))))
- (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
- (typeset-atom c
- (letrec ([mk
- (case-lambda
- [(elem color)
- (mk elem color (or (syntax-span c) 1))]
- [(elem color len)
- (elem-wrap
- (if (and (string? elem)
- (= len (string-length elem)))
- (make-element/cache (and color? color) elem)
- (make-sized-element (and color? color) elem len)))])])
- mk)
- color? 0 expr? escapes? defn?))))
+(define (typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
+ (let* ([c (syntax-ize c 0 #:expr? expr?)]
+ [s (syntax-e c)])
+ (if (or multi-line?
+ (and escapes? (eq? 'code:blank s))
+ (pair? s)
+ (mpair? s)
+ (vector? s)
+ (struct? s)
+ (box? s)
+ (null? s)
+ (hash? s)
+ (graph-defn? s)
+ (graph-reference? s)
+ (struct-proxy? s)
+ (and expr? (or (identifier? c)
+ (keyword? (syntax-e c)))))
+ (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap)
+ (typeset-atom c
+ (letrec ([mk
+ (case-lambda
+ [(elem color)
+ (mk elem color (or (syntax-span c) 1))]
+ [(elem color len)
+ (elem-wrap
+ (if (and (string? elem)
+ (= len (string-length elem)))
+ (make-element/cache (and color? color) elem)
+ (make-sized-element (and color? color) elem len)))])])
+ mk)
+ color? 0 expr? escapes? defn?))))
- (define (to-element c
- #:expr? [expr? #f]
- #:escapes? [escapes? #t]
- #:defn? [defn? #f])
- (typeset c #f "" "" "" #t expr? escapes? defn? values))
+(define (to-element c
+ #:expr? [expr? #f]
+ #:escapes? [escapes? #t]
+ #:defn? [defn? #f])
+ (typeset c #f "" "" "" #t expr? escapes? defn? values))
- (define (to-element/no-color c
- #:expr? [expr? #f]
- #:escapes? [escapes? #t])
- (typeset c #f "" "" "" #f expr? escapes? #f values))
+(define (to-element/no-color c
+ #:expr? [expr? #f]
+ #:escapes? [escapes? #t])
+ (typeset c #f "" "" "" #f expr? escapes? #f values))
- (define (to-paragraph c
- #:expr? [expr? #f]
- #:escapes? [escapes? #t]
- #:color? [color? #t]
- #:wrap-elem [elem-wrap (lambda (e) e)])
- (typeset c #t "" "" "" color? expr? escapes? #f elem-wrap))
+(define (to-paragraph c
+ #:expr? [expr? #f]
+ #:escapes? [escapes? #t]
+ #:color? [color? #t]
+ #:wrap-elem [elem-wrap (lambda (e) e)])
+ (typeset c #t "" "" "" color? expr? escapes? #f elem-wrap))
- (define ((to-paragraph/prefix pfx1 pfx sfx) c
- #:expr? [expr? #f]
- #:escapes? [escapes? #t]
- #:color? [color? #t]
- #:wrap-elem [elem-wrap (lambda (e) e)])
- (typeset c #t pfx1 pfx sfx color? expr? escapes? #f elem-wrap))
+(define ((to-paragraph/prefix pfx1 pfx sfx) c
+ #:expr? [expr? #f]
+ #:escapes? [escapes? #t]
+ #:color? [color? #t]
+ #:wrap-elem [elem-wrap (lambda (e) e)])
+ (typeset c #t pfx1 pfx sfx color? expr? escapes? #f elem-wrap))
- (begin-for-syntax
- (define-struct variable-id (sym)
- #:omit-define-syntaxes
- #:property prop:procedure (lambda (self stx)
- (raise-syntax-error
- #f
- (string-append
- "misuse of an identifier (not in `racket', etc.) that is"
- " bound as a code-typesetting variable")
- stx)))
- (define-struct element-id-transformer (proc)
- #:omit-define-syntaxes
- #:property prop:procedure (lambda (self stx)
- (raise-syntax-error
- #f
- (string-append
- "misuse of an identifier (not in `racket', etc.) that is"
- " bound as an code-typesetting element transformer")
- stx))))
+(begin-for-syntax
+ (define-struct variable-id (sym)
+ #:omit-define-syntaxes
+ #:property prop:procedure (lambda (self stx)
+ (raise-syntax-error
+ #f
+ (string-append
+ "misuse of an identifier (not in `racket', etc.) that is"
+ " bound as a code-typesetting variable")
+ stx)))
+ (define-struct element-id-transformer (proc)
+ #:omit-define-syntaxes
+ #:property prop:procedure (lambda (self stx)
+ (raise-syntax-error
+ #f
+ (string-append
+ "misuse of an identifier (not in `racket', etc.) that is"
+ " bound as an code-typesetting element transformer")
+ stx))))
- (define-syntax (define-code stx)
- (syntax-case stx ()
- [(_ code typeset-code uncode d->s stx-prop)
- (syntax/loc stx
- (define-syntax (code stx)
- (define (wrap-loc v ctx e)
- `(,#'d->s ,ctx
- ,e
- #(code
- ,(syntax-line v)
- ,(syntax-column v)
- ,(syntax-position v)
- ,(syntax-span v))))
- (define (stx->loc-s-expr/esc v uncode-id)
- (define (stx->loc-s-expr v)
- (let ([slv (and (identifier? v)
- (syntax-local-value v (lambda () #f)))])
- (cond
- [(variable-id? slv)
- (wrap-loc v #f `(,#'make-var-id ',(variable-id-sym slv)))]
- [(element-id-transformer? slv)
- (wrap-loc v #f ((element-id-transformer-proc slv) v))]
- [(syntax? v)
- (let ([mk (wrap-loc
- v
- `(quote-syntax ,(datum->syntax v 'defcode))
- (syntax-case v ()
- [(esc e)
- (and (identifier? #'esc)
- (free-identifier=? #'esc uncode-id))
- #'e]
- [else (stx->loc-s-expr (syntax-e v))]))])
- (let ([prop (syntax-property v 'paren-shape)])
- (if prop
- `(,#'stx-prop ,mk 'paren-shape ,prop)
- mk)))]
- [(null? v) 'null]
- [(list? v) `(list . ,(map stx->loc-s-expr v))]
- [(pair? v) `(cons ,(stx->loc-s-expr (car v))
- ,(stx->loc-s-expr (cdr v)))]
- [(vector? v) `(vector ,@(map
- stx->loc-s-expr
- (vector->list v)))]
- [(and (struct? v) (prefab-struct-key v))
- `(make-prefab-struct (quote ,(prefab-struct-key v))
- ,@(map
- stx->loc-s-expr
- (cdr (vector->list (struct->vector v)))))]
- [(box? v) `(box ,(stx->loc-s-expr (unbox v)))]
- [(hash? v) `(,(cond
+(define-syntax (define-code stx)
+ (syntax-case stx ()
+ [(_ code typeset-code uncode d->s stx-prop)
+ (syntax/loc stx
+ (define-syntax (code stx)
+ (define (wrap-loc v ctx e)
+ `(,#'d->s ,ctx
+ ,e
+ #(code
+ ,(syntax-line v)
+ ,(syntax-column v)
+ ,(syntax-position v)
+ ,(syntax-span v))))
+ (define (stx->loc-s-expr/esc v uncode-id)
+ (define (stx->loc-s-expr v)
+ (let ([slv (and (identifier? v)
+ (syntax-local-value v (lambda () #f)))])
+ (cond
+ [(variable-id? slv)
+ (wrap-loc v #f `(,#'make-var-id ',(variable-id-sym slv)))]
+ [(element-id-transformer? slv)
+ (wrap-loc v #f ((element-id-transformer-proc slv) v))]
+ [(syntax? v)
+ (let ([mk (wrap-loc
+ v
+ `(quote-syntax ,(datum->syntax v 'defcode))
+ (syntax-case v ()
+ [(esc e)
+ (and (identifier? #'esc)
+ (free-identifier=? #'esc uncode-id))
+ #'e]
+ [else (stx->loc-s-expr (syntax-e v))]))])
+ (let ([prop (syntax-property v 'paren-shape)])
+ (if prop
+ `(,#'stx-prop ,mk 'paren-shape ,prop)
+ mk)))]
+ [(null? v) 'null]
+ [(list? v) `(list . ,(map stx->loc-s-expr v))]
+ [(pair? v) `(cons ,(stx->loc-s-expr (car v))
+ ,(stx->loc-s-expr (cdr v)))]
+ [(vector? v) `(vector ,@(map
+ stx->loc-s-expr
+ (vector->list v)))]
+ [(and (struct? v) (prefab-struct-key v))
+ `(make-prefab-struct (quote ,(prefab-struct-key v))
+ ,@(map
+ stx->loc-s-expr
+ (cdr (vector->list (struct->vector v)))))]
+ [(box? v) `(box ,(stx->loc-s-expr (unbox v)))]
+ [(hash? v) `(,(cond
[(hash-eq? v) 'make-immutable-hasheq]
[(hash-eqv? v) 'make-immutable-hasheqv]
[else 'make-immutable-hash])
- (list
- ,@(hash-map
- v
- (lambda (k v)
- `(cons (quote ,k)
- ,(stx->loc-s-expr v))))))]
- [else `(quote ,v)])))
- (stx->loc-s-expr v))
- (define (cvt s uncode-id)
- (datum->syntax #'here (stx->loc-s-expr/esc s uncode-id) #f))
- (if (eq? (syntax-local-context) 'expression)
- (syntax-case stx ()
- [(_ #:escape uncode-id expr) #`(typeset-code #,(cvt #'expr #'uncode-id))]
- [(_ expr) #`(typeset-code #,(cvt #'expr #'uncode))]
- [(_ #:escape uncode-id expr (... ...))
- #`(typeset-code #,(cvt #'(code:line expr (... ...)) #'uncode-id))]
- [(_ expr (... ...))
- #`(typeset-code #,(cvt #'(code:line expr (... ...)) #'uncode))])
- (quasisyntax/loc stx
- (#%expression #,stx)))))]
- [(_ code typeset-code uncode d->s)
- #'(define-code code typeset-code uncode d->s syntax-property)]
- [(_ code typeset-code uncode)
- #'(define-code code typeset-code uncode datum->syntax syntax-property)]
- [(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
+ (list
+ ,@(hash-map
+ v
+ (lambda (k v)
+ `(cons (quote ,k)
+ ,(stx->loc-s-expr v))))))]
+ [else `(quote ,v)])))
+ (stx->loc-s-expr v))
+ (define (cvt s uncode-id)
+ (datum->syntax #'here (stx->loc-s-expr/esc s uncode-id) #f))
+ (if (eq? (syntax-local-context) 'expression)
+ (syntax-case stx ()
+ [(_ #:escape uncode-id expr) #`(typeset-code #,(cvt #'expr #'uncode-id))]
+ [(_ expr) #`(typeset-code #,(cvt #'expr #'uncode))]
+ [(_ #:escape uncode-id expr (... ...))
+ #`(typeset-code #,(cvt #'(code:line expr (... ...)) #'uncode-id))]
+ [(_ expr (... ...))
+ #`(typeset-code #,(cvt #'(code:line expr (... ...)) #'uncode))])
+ (quasisyntax/loc stx
+ (#%expression #,stx)))))]
+ [(_ code typeset-code uncode d->s)
+ #'(define-code code typeset-code uncode d->s syntax-property)]
+ [(_ code typeset-code uncode)
+ #'(define-code code typeset-code uncode datum->syntax syntax-property)]
+ [(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
- (define syntax-ize-hook (make-parameter (lambda (v col) #f)))
+(define syntax-ize-hook (make-parameter (lambda (v col) #f)))
- (define (vector->short-list v extract)
- (vector->list v)
- #;
- (let ([l (vector->list v)])
- (reverse (list-tail
- (reverse l)
- (- (vector-length v)
- (let loop ([i (sub1 (vector-length v))])
- (cond
- [(zero? i) 1]
- [(eq? (extract (vector-ref v i))
- (extract (vector-ref v (sub1 i))))
- (loop (sub1 i))]
- [else (add1 i)])))))))
+(define (vector->short-list v extract)
+ (vector->list v)
+ #;
+ (let ([l (vector->list v)])
+ (reverse (list-tail
+ (reverse l)
+ (- (vector-length v)
+ (let loop ([i (sub1 (vector-length v))])
+ (cond
+ [(zero? i) 1]
+ [(eq? (extract (vector-ref v i))
+ (extract (vector-ref v (sub1 i))))
+ (loop (sub1 i))]
+ [else (add1 i)])))))))
- (define (short-list->vector v l)
- (list->vector
- (let ([n (length l)])
- (if (n . < . (vector-length v))
- (reverse (let loop ([r (reverse l)][i (- (vector-length v) n)])
- (if (zero? i)
- r
- (loop (cons (car r) r) (sub1 i)))))
- l))))
+(define (short-list->vector v l)
+ (list->vector
+ (let ([n (length l)])
+ (if (n . < . (vector-length v))
+ (reverse (let loop ([r (reverse l)][i (- (vector-length v) n)])
+ (if (zero? i)
+ r
+ (loop (cons (car r) r) (sub1 i)))))
+ l))))
- (define-struct var-id (sym))
- (define-struct shaped-parens (val shape))
- (define-struct long-boolean (val))
- (define-struct just-context (val ctx))
- (define-struct alternate-display (id string))
- (define-struct literal-syntax (stx))
- (define-struct struct-proxy (name content))
+(define-struct var-id (sym))
+(define-struct shaped-parens (val shape))
+(define-struct long-boolean (val))
+(define-struct just-context (val ctx))
+(define-struct alternate-display (id string))
+(define-struct literal-syntax (stx))
+(define-struct struct-proxy (name content))
- (define-struct graph-reference (bx))
- (define-struct graph-defn (r bx))
+(define-struct graph-reference (bx))
+(define-struct graph-defn (r bx))
- (define (syntax-ize v col [line 1] #:expr? [expr? #f])
- (do-syntax-ize v col line (box #hasheq()) #f (and expr? 0) #f))
+(define (syntax-ize v col [line 1] #:expr? [expr? #f])
+ (do-syntax-ize v col line (box #hasheq()) #f (and expr? 0) #f))
- (define (graph-count ht graph?)
- (and graph?
- (let ([n (hash-ref (unbox ht) '#%graph-count 0)])
- (set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n)))
- n)))
+(define (graph-count ht graph?)
+ (and graph?
+ (let ([n (hash-ref (unbox ht) '#%graph-count 0)])
+ (set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n)))
+ n)))
- (define-struct forced-pair (car cdr))
+(define-struct forced-pair (car cdr))
- (define (quotable? v)
- (define graph (make-hasheq))
- (let quotable? ([v v])
- (if (hash-ref graph v #f)
- #t
- (begin
- (hash-set! graph v #t)
- (cond
- [(syntax? v) (quotable? (syntax-e v))]
- [(pair? v) (and (quotable? (car v))
- (quotable? (cdr v)))]
- [(vector? v) (andmap quotable? (vector->list v))]
- [(hash? v) (for/and ([(k v) (in-hash v)])
- (and (quotable? k)
- (quotable? v)))]
- [(box? v) (quotable? (unbox v))]
- [(and (struct? v)
- (prefab-struct-key v))
- (andmap quotable? (vector->list (struct->vector v)))]
- [(struct? v) (if (custom-write? v)
- (case (or (and (custom-print-quotable? v)
- (custom-print-quotable-accessor v))
- 'self)
- [(self always) #t]
- [(never) #f]
- [(maybe)
- (andmap quotable? (vector->list (struct->vector v)))])
- #f)]
- [(struct-proxy? v) #f]
- [(mpair? v) #f]
- [else #t])))))
+(define (quotable? v)
+ (define graph (make-hasheq))
+ (let quotable? ([v v])
+ (if (hash-ref graph v #f)
+ #t
+ (begin
+ (hash-set! graph v #t)
+ (cond
+ [(syntax? v) (quotable? (syntax-e v))]
+ [(pair? v) (and (quotable? (car v))
+ (quotable? (cdr v)))]
+ [(vector? v) (andmap quotable? (vector->list v))]
+ [(hash? v) (for/and ([(k v) (in-hash v)])
+ (and (quotable? k)
+ (quotable? v)))]
+ [(box? v) (quotable? (unbox v))]
+ [(and (struct? v)
+ (prefab-struct-key v))
+ (andmap quotable? (vector->list (struct->vector v)))]
+ [(struct? v) (if (custom-write? v)
+ (case (or (and (custom-print-quotable? v)
+ (custom-print-quotable-accessor v))
+ 'self)
+ [(self always) #t]
+ [(never) #f]
+ [(maybe)
+ (andmap quotable? (vector->list (struct->vector v)))])
+ #f)]
+ [(struct-proxy? v) #f]
+ [(mpair? v) #f]
+ [else #t])))))
- (define (do-syntax-ize v col line ht graph? qq no-cons?)
- (cond
- [((syntax-ize-hook) v col)
- => (lambda (r) r)]
- [(shaped-parens? v)
- (syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #f qq #f)
- 'paren-shape
- (shaped-parens-shape v))]
- [(long-boolean? v)
- (datum->syntax #f
- (and (long-boolean-val v) #t)
- (vector #f line col (+ 1 col) (if (long-boolean-val v) 5 6)))]
- [(just-context? v)
- (let ([s (do-syntax-ize (just-context-val v) col line ht #f qq #f)])
- (datum->syntax (just-context-ctx v)
- (syntax-e s)
- s
- s
- (just-context-ctx v)))]
- [(alternate-display? v)
- (let ([s (do-syntax-ize (alternate-display-id v) col line ht #f qq #f)])
- (syntax-property s
- 'display-string
- (alternate-display-string v)))]
- [(hash-ref (unbox ht) v #f)
- => (lambda (m)
- (unless (unbox m)
- (set-box! m #t))
- (datum->syntax #f
- (make-graph-reference m)
- (vector #f line col (+ 1 col) 1)))]
- [(and qq
- (zero? qq)
- (or (pair? v)
- (forced-pair? v)
- (vector? v)
- (hash? v)
- (box? v)
- (and (struct? v)
- (prefab-struct-key v)))
- (quotable? v)
- (not no-cons?))
- ;; Add a quote:
- (let ([l (do-syntax-ize v (add1 col) line ht #f 1 #f)])
- (datum->syntax #f
- (syntax-e l)
- (vector (syntax-source l)
- (syntax-line l)
- (sub1 (syntax-column l))
- (max 0 (sub1 (syntax-position l)))
- (add1 (syntax-span l)))))]
- [(and (list? v)
- (pair? v)
- (or (not qq)
- (positive? qq)
- (quotable? v))
- (let ([s (let ([s (car v)])
- (if (just-context? s)
- (just-context-val s)
- s))])
- (memq s '(quote unquote unquote-splicing)))
- (not no-cons?))
- => (lambda (s)
- (let* ([delta (if (and qq (zero? qq))
- 1
- 0)]
- [c (do-syntax-ize (cadr v) (+ col delta) line ht #f qq #f)])
- (datum->syntax #f
- (list (do-syntax-ize (car v) col line ht #f qq #f)
- c)
- (vector #f line col (+ 1 col)
- (+ delta
- (syntax-span c))))))]
- [(or (list? v)
- (vector? v)
- (and (struct? v)
- (or (and qq
- ;; Watch out for partially transparent subtypes of `element'
- ;; or convertible values:
- (not (convertible? v))
- (not (element? v)))
- (prefab-struct-key v))))
- (let ([orig-ht (unbox ht)]
- [graph-box (box (graph-count ht graph?))])
- (set-box! ht (hash-set (unbox ht) v graph-box))
- (let* ([graph-sz (if graph?
- (+ 2 (string-length (format "~a" (unbox graph-box))))
- 0)]
- [vec-sz (cond
+(define (do-syntax-ize v col line ht graph? qq no-cons?)
+ (cond
+ [((syntax-ize-hook) v col)
+ => (lambda (r) r)]
+ [(shaped-parens? v)
+ (syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #f qq #f)
+ 'paren-shape
+ (shaped-parens-shape v))]
+ [(long-boolean? v)
+ (datum->syntax #f
+ (and (long-boolean-val v) #t)
+ (vector #f line col (+ 1 col) (if (long-boolean-val v) 5 6)))]
+ [(just-context? v)
+ (let ([s (do-syntax-ize (just-context-val v) col line ht #f qq #f)])
+ (datum->syntax (just-context-ctx v)
+ (syntax-e s)
+ s
+ s
+ (just-context-ctx v)))]
+ [(alternate-display? v)
+ (let ([s (do-syntax-ize (alternate-display-id v) col line ht #f qq #f)])
+ (syntax-property s
+ 'display-string
+ (alternate-display-string v)))]
+ [(hash-ref (unbox ht) v #f)
+ => (lambda (m)
+ (unless (unbox m)
+ (set-box! m #t))
+ (datum->syntax #f
+ (make-graph-reference m)
+ (vector #f line col (+ 1 col) 1)))]
+ [(and qq
+ (zero? qq)
+ (or (pair? v)
+ (forced-pair? v)
+ (vector? v)
+ (hash? v)
+ (box? v)
+ (and (struct? v)
+ (prefab-struct-key v)))
+ (quotable? v)
+ (not no-cons?))
+ ;; Add a quote:
+ (let ([l (do-syntax-ize v (add1 col) line ht #f 1 #f)])
+ (datum->syntax #f
+ (syntax-e l)
+ (vector (syntax-source l)
+ (syntax-line l)
+ (sub1 (syntax-column l))
+ (max 0 (sub1 (syntax-position l)))
+ (add1 (syntax-span l)))))]
+ [(and (list? v)
+ (pair? v)
+ (or (not qq)
+ (positive? qq)
+ (quotable? v))
+ (let ([s (let ([s (car v)])
+ (if (just-context? s)
+ (just-context-val s)
+ s))])
+ (memq s '(quote unquote unquote-splicing)))
+ (not no-cons?))
+ => (lambda (s)
+ (let* ([delta (if (and qq (zero? qq))
+ 1
+ 0)]
+ [c (do-syntax-ize (cadr v) (+ col delta) line ht #f qq #f)])
+ (datum->syntax #f
+ (list (do-syntax-ize (car v) col line ht #f qq #f)
+ c)
+ (vector #f line col (+ 1 col)
+ (+ delta
+ (syntax-span c))))))]
+ [(or (list? v)
+ (vector? v)
+ (and (struct? v)
+ (or (and qq
+ ;; Watch out for partially transparent subtypes of `element'
+ ;; or convertible values:
+ (not (convertible? v))
+ (not (element? v)))
+ (prefab-struct-key v))))
+ (let ([orig-ht (unbox ht)]
+ [graph-box (box (graph-count ht graph?))])
+ (set-box! ht (hash-set (unbox ht) v graph-box))
+ (let* ([graph-sz (if graph?
+ (+ 2 (string-length (format "~a" (unbox graph-box))))
+ 0)]
+ [vec-sz (cond
[(vector? v)
(if (and qq (zero? qq)) 0 1)]
[(struct? v)
@@ -1230,15 +1231,15 @@
2
0)]
[else 0])]
- [delta (if (and qq (zero? qq))
- (cond
+ [delta (if (and qq (zero? qq))
+ (cond
[(vector? v) 8] ; `(vector '
[(struct? v) 1] ; '('
[no-cons? 1] ; '('
[else 6]) ; `(list '
- 1)]
- [r (let ([l (let loop ([col (+ col delta vec-sz graph-sz)]
- [v (cond
+ 1)]
+ [r (let ([l (let loop ([col (+ col delta vec-sz graph-sz)]
+ [v (cond
[(vector? v)
(vector->short-list v values)]
[(struct? v)
@@ -1248,13 +1249,13 @@
(object-name v)))
(cdr (vector->list (struct->vector v qq-ellipses))))]
[else v])])
- (if (null? v)
- null
- (let ([i (do-syntax-ize (car v) col line ht #f qq #f)])
- (cons i
- (loop (+ col 1 (syntax-span i)) (cdr v))))))])
- (datum->syntax #f
- (cond
+ (if (null? v)
+ null
+ (let ([i (do-syntax-ize (car v) col line ht #f qq #f)])
+ (cons i
+ (loop (+ col 1 (syntax-span i)) (cdr v))))))])
+ (datum->syntax #f
+ (cond
[(vector? v) (short-list->vector v l)]
[(struct? v)
(let ([pf (prefab-struct-key v)])
@@ -1262,19 +1263,19 @@
(apply make-prefab-struct (prefab-struct-key v) (cdr l))
(make-struct-proxy (car l) (cdr l))))]
[else l])
- (vector #f line
- (+ graph-sz col)
- (+ 1 graph-sz col)
- (+ 1
- vec-sz
- delta
- (if (zero? (length l))
- 0
- (sub1 (length l)))
- (apply + (map syntax-span l))))))])
- (unless graph?
- (set-box! ht (hash-set (unbox ht) v #f)))
- (cond
+ (vector #f line
+ (+ graph-sz col)
+ (+ 1 graph-sz col)
+ (+ 1
+ vec-sz
+ delta
+ (if (zero? (length l))
+ 0
+ (sub1 (length l)))
+ (apply + (map syntax-span l))))))])
+ (unless graph?
+ (set-box! ht (hash-set (unbox ht) v #f)))
+ (cond
[graph? (datum->syntax #f
(make-graph-defn r graph-box)
(vector #f (syntax-line r)
@@ -1286,46 +1287,46 @@
(set-box! ht orig-ht)
(do-syntax-ize v col line ht #t qq #f)]
[else r])))]
- [(or (pair? v)
- (mpair? v)
- (forced-pair? v))
- (let ([carv (if (pair? v) (car v) (if (mpair? v) (mcar v) (forced-pair-car v)))]
- [cdrv (if (pair? v) (cdr v) (if (mpair? v) (mcdr v) (forced-pair-cdr v)))]
- [orig-ht (unbox ht)]
- [graph-box (box (graph-count ht graph?))])
- (set-box! ht (hash-set (unbox ht) v graph-box))
- (let* ([delta (if (and qq (zero? qq) (not no-cons?))
- (if (mpair? v)
- 7 ; "(mcons "
- (if (or (list? cdrv)
- (not (pair? cdrv)))
- 6 ; "(cons "
- 7)) ; "(list* "
- 1)]
- [inc (if graph?
- (+ 2 (string-length (format "~a" (unbox graph-box))))
- 0)]
- [a (do-syntax-ize carv (+ col delta inc) line ht #f qq #f)]
- [sep (if (and (pair? v)
- (pair? cdrv)
- ;; FIXME: what if it turns out to be a graph reference?
- (not (hash-ref (unbox ht) cdrv #f)))
- 0
- (if (and qq (zero? qq))
- 1
- 3))]
- [b (do-syntax-ize cdrv (+ col delta inc (syntax-span a) sep) line ht #f qq #t)])
- (let ([r (datum->syntax #f
- (if (mpair? v)
- (mcons a b)
- (cons a b))
- (vector #f line (+ col inc) (+ delta col inc)
- (+ 1 delta
- (if (and qq (zero? qq)) 1 0)
- sep (syntax-span a) (syntax-span b))))])
- (unless graph?
- (set-box! ht (hash-set (unbox ht) v #f)))
- (cond
+ [(or (pair? v)
+ (mpair? v)
+ (forced-pair? v))
+ (let ([carv (if (pair? v) (car v) (if (mpair? v) (mcar v) (forced-pair-car v)))]
+ [cdrv (if (pair? v) (cdr v) (if (mpair? v) (mcdr v) (forced-pair-cdr v)))]
+ [orig-ht (unbox ht)]
+ [graph-box (box (graph-count ht graph?))])
+ (set-box! ht (hash-set (unbox ht) v graph-box))
+ (let* ([delta (if (and qq (zero? qq) (not no-cons?))
+ (if (mpair? v)
+ 7 ; "(mcons "
+ (if (or (list? cdrv)
+ (not (pair? cdrv)))
+ 6 ; "(cons "
+ 7)) ; "(list* "
+ 1)]
+ [inc (if graph?
+ (+ 2 (string-length (format "~a" (unbox graph-box))))
+ 0)]
+ [a (do-syntax-ize carv (+ col delta inc) line ht #f qq #f)]
+ [sep (if (and (pair? v)
+ (pair? cdrv)
+ ;; FIXME: what if it turns out to be a graph reference?
+ (not (hash-ref (unbox ht) cdrv #f)))
+ 0
+ (if (and qq (zero? qq))
+ 1
+ 3))]
+ [b (do-syntax-ize cdrv (+ col delta inc (syntax-span a) sep) line ht #f qq #t)])
+ (let ([r (datum->syntax #f
+ (if (mpair? v)
+ (mcons a b)
+ (cons a b))
+ (vector #f line (+ col inc) (+ delta col inc)
+ (+ 1 delta
+ (if (and qq (zero? qq)) 1 0)
+ sep (syntax-span a) (syntax-span b))))])
+ (unless graph?
+ (set-box! ht (hash-set (unbox ht) v #f)))
+ (cond
[graph? (datum->syntax #f
(make-graph-defn r graph-box)
(vector #f line col (+ delta col)
@@ -1335,48 +1336,48 @@
(set-box! ht orig-ht)
(do-syntax-ize v col line ht #t qq #f)]
[else r]))))]
- [(box? v)
- (let* ([delta (if (and qq (zero? qq))
- 5 ; "(box "
- 2)] ; "#&"
- [a (do-syntax-ize (unbox v) (+ col delta) line ht #f qq #f)])
- (datum->syntax #f
- (box a)
- (vector #f line col (+ 1 col)
- (+ delta (if (and qq (zero? qq)) 1 0) (syntax-span a)))))]
- [(hash? v)
- (let* ([delta (cond
+ [(box? v)
+ (let* ([delta (if (and qq (zero? qq))
+ 5 ; "(box "
+ 2)] ; "#&"
+ [a (do-syntax-ize (unbox v) (+ col delta) line ht #f qq #f)])
+ (datum->syntax #f
+ (box a)
+ (vector #f line col (+ 1 col)
+ (+ delta (if (and qq (zero? qq)) 1 0) (syntax-span a)))))]
+ [(hash? v)
+ (let* ([delta (cond
[(hash-eq? v) 7]
[(hash-eqv? v) 8]
[else 6])]
- [undelta (if (and qq (zero? qq))
- (- delta 1)
- 0)]
- [pairs (if (and qq (zero? qq))
- (let ([ls (do-syntax-ize (apply append (hash-map v (lambda (k v) (list k v))))
- (+ col delta -1) line ht #f qq #t)])
- (datum->syntax
- #f
- (let loop ([l (syntax->list ls)])
- (if (null? l)
- null
- (cons (cons (car l) (cadr l)) (loop (cddr l)))))
- ls))
- (do-syntax-ize (hash-map v make-forced-pair) (+ col delta) line ht #f qq #f))])
- (datum->syntax #f
- ((cond
+ [undelta (if (and qq (zero? qq))
+ (- delta 1)
+ 0)]
+ [pairs (if (and qq (zero? qq))
+ (let ([ls (do-syntax-ize (apply append (hash-map v (lambda (k v) (list k v))))
+ (+ col delta -1) line ht #f qq #t)])
+ (datum->syntax
+ #f
+ (let loop ([l (syntax->list ls)])
+ (if (null? l)
+ null
+ (cons (cons (car l) (cadr l)) (loop (cddr l)))))
+ ls))
+ (do-syntax-ize (hash-map v make-forced-pair) (+ col delta) line ht #f qq #f))])
+ (datum->syntax #f
+ ((cond
[(hash-eq? v) make-immutable-hasheq]
[(hash-eqv? v) make-immutable-hasheqv]
[else make-immutable-hash])
- (map (lambda (p)
- (let ([p (syntax-e p)])
- (cons (syntax->datum (car p))
- (cdr p))))
- (syntax->list pairs)))
- (vector (syntax-source pairs)
- (syntax-line pairs)
- (max 0 (- (syntax-column pairs) undelta))
- (max 1 (- (syntax-position pairs) undelta))
- (+ (syntax-span pairs) undelta))))]
- [else
- (datum->syntax #f v (vector #f line col (+ 1 col) 1))])))
+ (map (lambda (p)
+ (let ([p (syntax-e p)])
+ (cons (syntax->datum (car p))
+ (cdr p))))
+ (syntax->list pairs)))
+ (vector (syntax-source pairs)
+ (syntax-line pairs)
+ (max 0 (- (syntax-column pairs) undelta))
+ (max 1 (- (syntax-position pairs) undelta))
+ (+ (syntax-span pairs) undelta))))]
+ [else
+ (datum->syntax #f v (vector #f line col (+ 1 col) 1))]))
diff --git a/scribble-lib/scribble/search.rkt b/scribble-lib/scribble/search.rkt
index 103ff7c9..195b3970 100644
--- a/scribble-lib/scribble/search.rkt
+++ b/scribble-lib/scribble/search.rkt
@@ -1,142 +1,143 @@
-(module search racket/base
- (require "struct.rkt"
- "basic.rkt"
- syntax/modcode)
+#lang racket/base
- (provide find-racket-tag
- (rename-out [find-racket-tag find-scheme-tag]))
+(require "struct.rkt"
+ "basic.rkt"
+ syntax/modcode)
- (define module-info-cache (make-hasheq))
+(provide find-racket-tag
+ (rename-out [find-racket-tag find-scheme-tag]))
- (define (module-path-index-rejoin mpi rel-to)
- (let-values ([(name base) (module-path-index-split mpi)])
- (cond
- [(not name) rel-to]
- [(not base) mpi]
- [else
- (module-path-index-join name
- (module-path-index-rejoin base rel-to))])))
+(define module-info-cache (make-hasheq))
- (define (try thunk fail-thunk)
- (with-handlers* ([exn:fail? (lambda (exn) (fail-thunk))])
- (thunk)))
+(define (module-path-index-rejoin mpi rel-to)
+ (let-values ([(name base) (module-path-index-split mpi)])
+ (cond
+ [(not name) rel-to]
+ [(not base) mpi]
+ [else
+ (module-path-index-join name
+ (module-path-index-rejoin base rel-to))])))
- (define (find-racket-tag part ri stx/binding phase-level)
- ;; The phase-level argument is used only when `stx/binding'
- ;; is an identifier.
- ;;
- ;; Note: documentation keys currently don't distinguish different
- ;; phase definitions of an identifier from a source module.
- ;; That is, there's no way to document (define x ....) differently
- ;; from (define-for-syntax x ...). This isn't a problem in practice,
- ;; because no one uses the same name for different-phase exported
- ;; bindings.
- ;;
- ;; Formerly, we assumed that bindings are defined as originating from some
- ;; module at phase 0. [Maybe it's defined at phase 1 and re-exported
- ;; later for phase 0 (after a require-for-template), in which case the
- ;; re-exporting module is the one we find.] That assumption has been
- ;; lifted, however; search for "GONE" below.
- (let ([b (cond
- [(identifier? stx/binding)
- (identifier-binding stx/binding phase-level)]
- [(and (list? stx/binding)
- (= 7 (length stx/binding)))
- stx/binding]
- [else
- (and (not (symbol? (car stx/binding)))
- (list #f
- (cadr stx/binding)
- (car stx/binding)
- (cadr stx/binding)
- (if (= 2 (length stx/binding))
- 0
- (caddr stx/binding))
- (if (= 2 (length stx/binding))
- 0
- (cadddr stx/binding))
- (if (= 2 (length stx/binding))
- 0
- (cadddr (cdr stx/binding)))))])])
- (and
- (pair? b)
- (let ([seen (make-hash)]
- [search-key #f])
- (let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
- [rqueue null]
- [need-result? #t])
- (cond
- [(null? queue)
- (if (null? rqueue)
- ;; Not documented
- #f
- (loop (reverse rqueue) null need-result?))]
- [else
- (let ([mod (list-ref (car queue) 0)]
- [id (list-ref (car queue) 1)]
- [defn-phase (list-ref (car queue) 2)]
- [import-phase (list-ref (car queue) 3)]
- [export-phase (list-ref (car queue) 4)]
- [queue (cdr queue)])
- (let* ([rmp (module-path-index-resolve mod)]
- [eb (and ;; GONE: (equal? 0 export-phase) ;; look for the phase-0 export; good idea?
- (list (module-path-index->taglet mod)
- id))])
- (when (and eb
- (not search-key))
- (set! search-key eb))
- (let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
- (let* ([here-result
- (and need-result?
- v
- (let ([v (resolve-get/tentative part ri `(form ,eb))])
- (or (and v `(form ,eb))
- `(def ,eb))))]
- [need-result? (and need-result? (not here-result))]
- [rmp-name (resolved-module-path-name rmp)])
- ;; Even if we've found `here-result', look deeper so that we have
- ;; consistent `dep' results.
- (let ([nest-result
- ;; Maybe it's re-exported from this module...
- ;; Try a shortcut:
- (if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
- ;; Not defined through this path, so keep looking
- (loop queue rqueue need-result?)
- ;; Check parents, if we can get the source:
- (if (and (or (path? rmp-name)
- (and (list? rmp-name)
- (path? (car rmp-name))))
- (not (hash-ref seen (cons export-phase rmp) #f)))
- (let ([exports
- (hash-ref
- module-info-cache
- rmp
- (lambda ()
- (let-values ([(valss stxess)
- (try
- (lambda ()
- ;; First, try using bytecode:
- (module-compiled-exports
- (get-module-code (if (list? rmp-name)
- (car rmp-name)
- rmp-name)
- #:submodule-path (if (list? rmp-name)
- (cdr rmp-name)
- '())
- #:choose (lambda (src zo so) 'zo))))
- (lambda ()
- (try
- (lambda ()
- ;; Bytecode not available. Declaration in the
- ;; current namespace?
- (module->exports rmp))
- (lambda ()
- (values null null)))))])
- (let ([t
- ;; Merge the two association lists:
- (let loop ([base valss]
- [stxess stxess])
- (cond
+(define (try thunk fail-thunk)
+ (with-handlers* ([exn:fail? (lambda (exn) (fail-thunk))])
+ (thunk)))
+
+(define (find-racket-tag part ri stx/binding phase-level)
+ ;; The phase-level argument is used only when `stx/binding'
+ ;; is an identifier.
+ ;;
+ ;; Note: documentation keys currently don't distinguish different
+ ;; phase definitions of an identifier from a source module.
+ ;; That is, there's no way to document (define x ....) differently
+ ;; from (define-for-syntax x ...). This isn't a problem in practice,
+ ;; because no one uses the same name for different-phase exported
+ ;; bindings.
+ ;;
+ ;; Formerly, we assumed that bindings are defined as originating from some
+ ;; module at phase 0. [Maybe it's defined at phase 1 and re-exported
+ ;; later for phase 0 (after a require-for-template), in which case the
+ ;; re-exporting module is the one we find.] That assumption has been
+ ;; lifted, however; search for "GONE" below.
+ (let ([b (cond
+ [(identifier? stx/binding)
+ (identifier-binding stx/binding phase-level)]
+ [(and (list? stx/binding)
+ (= 7 (length stx/binding)))
+ stx/binding]
+ [else
+ (and (not (symbol? (car stx/binding)))
+ (list #f
+ (cadr stx/binding)
+ (car stx/binding)
+ (cadr stx/binding)
+ (if (= 2 (length stx/binding))
+ 0
+ (caddr stx/binding))
+ (if (= 2 (length stx/binding))
+ 0
+ (cadddr stx/binding))
+ (if (= 2 (length stx/binding))
+ 0
+ (cadddr (cdr stx/binding)))))])])
+ (and
+ (pair? b)
+ (let ([seen (make-hash)]
+ [search-key #f])
+ (let loop ([queue (list (list (caddr b) (cadddr b) (list-ref b 4) (list-ref b 5) (list-ref b 6)))]
+ [rqueue null]
+ [need-result? #t])
+ (cond
+ [(null? queue)
+ (if (null? rqueue)
+ ;; Not documented
+ #f
+ (loop (reverse rqueue) null need-result?))]
+ [else
+ (let ([mod (list-ref (car queue) 0)]
+ [id (list-ref (car queue) 1)]
+ [defn-phase (list-ref (car queue) 2)]
+ [import-phase (list-ref (car queue) 3)]
+ [export-phase (list-ref (car queue) 4)]
+ [queue (cdr queue)])
+ (let* ([rmp (module-path-index-resolve mod)]
+ [eb (and ;; GONE: (equal? 0 export-phase) ;; look for the phase-0 export; good idea?
+ (list (module-path-index->taglet mod)
+ id))])
+ (when (and eb
+ (not search-key))
+ (set! search-key eb))
+ (let ([v (and eb (resolve-search search-key part ri `(dep ,eb)))])
+ (let* ([here-result
+ (and need-result?
+ v
+ (let ([v (resolve-get/tentative part ri `(form ,eb))])
+ (or (and v `(form ,eb))
+ `(def ,eb))))]
+ [need-result? (and need-result? (not here-result))]
+ [rmp-name (resolved-module-path-name rmp)])
+ ;; Even if we've found `here-result', look deeper so that we have
+ ;; consistent `dep' results.
+ (let ([nest-result
+ ;; Maybe it's re-exported from this module...
+ ;; Try a shortcut:
+ (if (eq? rmp (and (car b) (module-path-index-resolve (car b))))
+ ;; Not defined through this path, so keep looking
+ (loop queue rqueue need-result?)
+ ;; Check parents, if we can get the source:
+ (if (and (or (path? rmp-name)
+ (and (list? rmp-name)
+ (path? (car rmp-name))))
+ (not (hash-ref seen (cons export-phase rmp) #f)))
+ (let ([exports
+ (hash-ref
+ module-info-cache
+ rmp
+ (lambda ()
+ (let-values ([(valss stxess)
+ (try
+ (lambda ()
+ ;; First, try using bytecode:
+ (module-compiled-exports
+ (get-module-code (if (list? rmp-name)
+ (car rmp-name)
+ rmp-name)
+ #:submodule-path (if (list? rmp-name)
+ (cdr rmp-name)
+ '())
+ #:choose (lambda (src zo so) 'zo))))
+ (lambda ()
+ (try
+ (lambda ()
+ ;; Bytecode not available. Declaration in the
+ ;; current namespace?
+ (module->exports rmp))
+ (lambda ()
+ (values null null)))))])
+ (let ([t
+ ;; Merge the two association lists:
+ (let loop ([base valss]
+ [stxess stxess])
+ (cond
[(null? stxess) base]
[(assoc (caar stxess) base)
=> (lambda (l)
@@ -148,40 +149,40 @@
[else (loop (cons (car stxess)
base)
(cdr stxess))]))])
- (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)))])
- (if 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?)
- (begin
- ;; 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?)))))
- ;; Can't get the module source, so continue with queue:
- (loop queue rqueue need-result?)))])
- (or here-result
- nest-result))))))])))))))
+ (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)))])
+ (if 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?)
+ (begin
+ ;; 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?)))))
+ ;; Can't get the module source, so continue with queue:
+ (loop queue rqueue need-result?)))])
+ (or here-result
+ nest-result))))))]))))))
From 8168a22492780b9fe346153621af3ee1b5a55147 Mon Sep 17 00:00:00 2001
From: Reuben Thomas <rrt@sc3d.org>
Date: Wed, 4 Dec 2019 22:01:41 +0000
Subject: [PATCH 09/17] scribble/config.scrbl: fix trivial typo
---
scribble-doc/scribblings/scribble/config.scrbl | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/scribble-doc/scribblings/scribble/config.scrbl b/scribble-doc/scribblings/scribble/config.scrbl
index 093fca40..07781950 100644
--- a/scribble-doc/scribblings/scribble/config.scrbl
+++ b/scribble-doc/scribblings/scribble/config.scrbl
@@ -332,7 +332,7 @@ The style classes:
[@css{versionbox} @elem{Outer wrapper for version}]
[@css{version} @elem{Inner wrapper for version in the case of search box and/or navigation.}]
- [@css{versionNoNav} @elem{Inner wrapper for version in the acse of no search box and navigation.}]
+ [@css{versionNoNav} @elem{Inner wrapper for version in the case of no search box and navigation.}]
[@spacer @spacer]
From 9b1f9bc1d2686866c62da787734f9afe5422b3c0 Mon Sep 17 00:00:00 2001
From: Reuben Thomas <rrt@sc3d.org>
Date: Mon, 11 Nov 2019 13:44:07 +0000
Subject: [PATCH 10/17] Make @emph nestable, logical markup
---
scribble-doc/scribblings/scribble/base.scrbl | 4 +++-
scribble-lib/scribble/base.rkt | 2 +-
scribble-lib/scribble/html-render.rkt | 1 +
scribble-lib/scribble/latex-render.rkt | 1 +
scribble-lib/scribble/markdown-render.rkt | 10 +++++++++-
scribble-lib/scribble/scribble.css | 20 ++++++++++++++++++++
6 files changed, 35 insertions(+), 3 deletions(-)
diff --git a/scribble-doc/scribblings/scribble/base.scrbl b/scribble-doc/scribblings/scribble/base.scrbl
index cecb9163..cf32ca7d 100644
--- a/scribble-doc/scribblings/scribble/base.scrbl
+++ b/scribble-doc/scribblings/scribble/base.scrbl
@@ -467,7 +467,9 @@ gets progressively smaller.}
gets progressively larger.}
@defproc[(emph [pre-content pre-content?] ...) element?]{
-The same as @racket[italic].}
+Like @racket[elem], but emphasised. Typically, italics are used for
+emphasis. Uses of @racket[emph] can be nested; typically this causes
+the text to alternate between italic and upright.}
@defproc[(literal [str string?] ...+) element?]{
diff --git a/scribble-lib/scribble/base.rkt b/scribble-lib/scribble/base.rkt
index ccfe8036..4463c7d5 100644
--- a/scribble-lib/scribble/base.rkt
+++ b/scribble-lib/scribble/base.rkt
@@ -258,7 +258,7 @@
(make-element 'larger (decode-content str)))
(define (emph . str)
- (make-element 'italic (decode-content str)))
+ (make-element 'emph (decode-content str)))
(define (tt . str)
(let* ([l (decode-content str)]
diff --git a/scribble-lib/scribble/html-render.rkt b/scribble-lib/scribble/html-render.rkt
index 4d08ac74..9c983baa 100644
--- a/scribble-lib/scribble/html-render.rkt
+++ b/scribble-lib/scribble/html-render.rkt
@@ -1607,6 +1607,7 @@
(cond
[(symbol? name)
(case name
+ [(emph) '([class "emph"])]
[(italic) '([style "font-style: italic"])]
[(bold) '([style "font-weight: bold"])]
[(tt) '([class "stt"])]
diff --git a/scribble-lib/scribble/latex-render.rkt b/scribble-lib/scribble/latex-render.rkt
index 78eaf307..6eeb8663 100644
--- a/scribble-lib/scribble/latex-render.rkt
+++ b/scribble-lib/scribble/latex-render.rkt
@@ -471,6 +471,7 @@
(cond
[(symbol? style-name)
(case style-name
+ [(emph) (wrap e "emph" tt?)]
[(italic) (wrap e "textit" tt?)]
[(bold) (wrap e "textbf" tt?)]
[(tt) (wrap e "Scribtexttt" #t)]
diff --git a/scribble-lib/scribble/markdown-render.rkt b/scribble-lib/scribble/markdown-render.rkt
index 16604c53..b971e4da 100644
--- a/scribble-lib/scribble/markdown-render.rkt
+++ b/scribble-lib/scribble/markdown-render.rkt
@@ -216,6 +216,9 @@
(define (italic? i)
(and (element? i) (eq? (element-style i) 'italic)))
+ (define (emph? i)
+ (and (element? i) (eq? (element-style i) 'emph)))
+
(define (code? i)
(and (element? i)
(let ([s (element-style i)])
@@ -259,6 +262,12 @@
[(and (italic? i) (not (in-italic?)) (not (in-code?)))
(recurse-wrapped "_" in-italic?)]
+ [(and (emph? i) (not (in-code?)))
+ (display "_") ;; zero-width space, underscore
+ (begin0
+ (super render-content i part ri)
+ (display "_"))] ;; underscore, zero-width space
+
[(and (preserve-spaces? i) (not (preserving-spaces?)))
(parameterize ([preserving-spaces? #t])
(render-content i part ri))]
@@ -378,4 +387,3 @@
([ptn (map car ptns&reps)]
[rep (map cdr ptns&reps)])
(regexp-replace* ptn str rep)))
-
diff --git a/scribble-lib/scribble/scribble.css b/scribble-lib/scribble/scribble.css
index 7da66740..2d0079d4 100644
--- a/scribble-lib/scribble/scribble.css
+++ b/scribble-lib/scribble/scribble.css
@@ -30,6 +30,26 @@
font-weight: bold;
}
+/* Emphasis: alternate italics and normal as we nest */
+.emph {
+ font-style: italic;
+}
+.emph .emph {
+ font-style: normal;
+}
+.emph .emph .emph {
+ font-style: italic;
+}
+.emph .emph .emph .emph {
+ font-style: normal;
+}
+.emph .emph .emph .emph .emph {
+ font-style: italic;
+}
+.emph .emph .emph .emph .emph .emph {
+ font-style: normal;
+}
+
/* ---------------------------------------- */
p, .SIntrapara {
From 6a8986f7c0ba4e241a44fa71cdf453010b21400c Mon Sep 17 00:00:00 2001
From: Ben Greenman <benjaminlgreenman@gmail.com>
Date: Sat, 7 Dec 2019 21:17:00 -0500
Subject: [PATCH 11/17] autobib: fix author formatting (#216) (#222)
- fix #216 by coercing author-element data to a string, add tests
- doc edits:
- import `scribble/core` to fix link to `content?`
- fix typo in `dissertation-location`
- replace unbound reference to `name/c` with a real contract
---
.../scriblib/scribblings/autobib.scrbl | 9 +++---
scribble-lib/scriblib/autobib.rkt | 2 +-
scribble-test/tests/scriblib/autobib.rkt | 29 ++++++++++++++++++-
3 files changed, 34 insertions(+), 6 deletions(-)
diff --git a/scribble-doc/scriblib/scribblings/autobib.scrbl b/scribble-doc/scriblib/scribblings/autobib.scrbl
index b63076cc..c31f0f98 100644
--- a/scribble-doc/scriblib/scribblings/autobib.scrbl
+++ b/scribble-doc/scriblib/scribblings/autobib.scrbl
@@ -1,5 +1,6 @@
#lang scribble/manual
-@(require (for-label scribble/struct
+@(require (for-label scribble/core
+ scribble/struct
scriblib/autobib
scheme/base
scheme/contract))
@@ -228,7 +229,7 @@ Both arguments are optional, but at least one must be supplied.}
Combines elements to generate an element that is suitable for
describing a technical report's location.}
-@defproc[(dissertation-location [#:institution institution edition any/c]
+@defproc[(dissertation-location [#:institution institution any/c]
[#:degree degree any/c "PhD"])
element?]{
@@ -264,7 +265,7 @@ alphabetized appropriately. Any of @racket[name] or @racket[names]
that are strings are
parsed in the same way as by @racket[make-bib].}
-@defproc[(org-author-name [name any/c]) element?]{
+@defproc[(org-author-name [name (or/c element? string?)]) element?]{
Converts an element for an organization name to one suitable for use
as a bib-value author.}
@@ -275,7 +276,7 @@ Generates an element that is suitable for use as a ``others'' author.
When combined with another author element via @racket[authors], the
one created by @racket[other-authors] renders as ``et al.''}
-@defproc[(editor [name name/c]) element?]{
+@defproc[(editor [name (or/c element? string?)]) element?]{
Takes an author-name element and create one that represents the editor
of a collection. If a @racket[name] is a string, it is parsed in the
diff --git a/scribble-lib/scriblib/autobib.rkt b/scribble-lib/scriblib/autobib.rkt
index ea23af09..710bbc82 100644
--- a/scribble-lib/scriblib/autobib.rkt
+++ b/scribble-lib/scriblib/autobib.rkt
@@ -621,7 +621,7 @@
(define (authors name . names*)
(define names (map parse-author (cons name names*)))
- (define slash-names (string-join (map author-element-names names) " / "))
+ (define slash-names (string-join (map (compose1 content->string author-element-names) names) " / "))
(define cite
(case (length names)
[(1) (author-element-cite (car names))]
diff --git a/scribble-test/tests/scriblib/autobib.rkt b/scribble-test/tests/scriblib/autobib.rkt
index b5512052..24388adf 100644
--- a/scribble-test/tests/scriblib/autobib.rkt
+++ b/scribble-test/tests/scriblib/autobib.rkt
@@ -55,7 +55,6 @@
(check-equal? (book-location #:edition "4th")
(mk-bookloc-elem/ed "4th")))
-
(test-case "techrpt-location"
(check-not-exn
(λ () (techrpt-location #:institution "MIT" #:number 'AIM-353)))
@@ -71,3 +70,31 @@
(λ () (dissertation-location #:institution "Georgetown University" #:degree "BS")))
(check-exn exn:fail:contract?
(λ () (dissertation-location #:degree "PhD"))))
+
+(test-case "authors"
+ ;; Define authors, make a bibliography
+ ;; https://github.com/racket/scribble/issues/216
+
+ (check-not-exn
+ (lambda ()
+ (define-cite cite citet gen-bib)
+ (define x*
+ (map
+ cite
+ (list
+ (make-bib
+ #:title "Histoire d'une Montagne"
+ #:author (authors "Elisée Reclus"))
+ (make-bib
+ #:title "The Jeffersonians"
+ #:author (authors "Richard B. Morris" "James Leslie Woods"))
+ (make-bib
+ #:title "Lucifer Magazine"
+ #:author (authors "H.P. Blavatsky" (other-authors)))
+ (make-bib
+ #:title "Dean's Electronics"
+ #:author (authors (org-author-name "robco") (org-author-name (authors "industries"))
+ (editor "mister") (editor (authors "crowley"))
+ (other-authors))))))
+ (gen-bib))))
+
From 6a5dfdffb8bcefd75c74f26be680c6468091bfd7 Mon Sep 17 00:00:00 2001
From: Ben Greenman <benjaminlgreenman@gmail.com>
Date: Sat, 7 Dec 2019 23:23:27 -0500
Subject: [PATCH 12/17] doc: autobib, fix overlapping for-label imports
scribble/struct and scribble/core provide some common identifiers,
so use only-in to import from scribble/core
---
scribble-doc/scriblib/scribblings/autobib.scrbl | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/scribble-doc/scriblib/scribblings/autobib.scrbl b/scribble-doc/scriblib/scribblings/autobib.scrbl
index c31f0f98..100f6a1b 100644
--- a/scribble-doc/scriblib/scribblings/autobib.scrbl
+++ b/scribble-doc/scriblib/scribblings/autobib.scrbl
@@ -1,5 +1,5 @@
#lang scribble/manual
-@(require (for-label scribble/core
+@(require (for-label (only-in scribble/core content?)
scribble/struct
scriblib/autobib
scheme/base
From aa5f0b767a2436c51c1a4baa67006dae48621e9a Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 8 Dec 2019 09:40:20 -0700
Subject: [PATCH 13/17] add 'no-toc+aux style property
---
scribble-doc/scribblings/scribble/core.scrbl | 11 ++++++++++-
scribble-lib/info.rkt | 2 +-
scribble-lib/scribble/html-render.rkt | 4 +++-
3 files changed, 14 insertions(+), 3 deletions(-)
diff --git a/scribble-doc/scribblings/scribble/core.scrbl b/scribble-doc/scribblings/scribble/core.scrbl
index 7da7e963..ba512a4e 100644
--- a/scribble-doc/scribblings/scribble/core.scrbl
+++ b/scribble-doc/scribblings/scribble/core.scrbl
@@ -441,6 +441,14 @@ The recognized @tech{style properties} are as follows:
listing except when those sub-parts are top-level entries in
the listing.}
+ @item{@indexed-racket['no-toc+aux] --- As a @tech{style property} for
+ the main part of a rendered page, causes the HTML output to not
+ include a margin box for the main table of contents, ``on this
+ page'', or tables with the @racket['aux] style property. The
+ @racket['no-toc+aux] property effectively implies
+ @racket['no-toc] and @racket['no-sidebar], but also suppresses
+ @racket['aux] tables.}
+
@item{@indexed-racket['no-toc] --- As a @tech{style property} for the main part of a
rendered page, causes the HTML output to not include a margin box
for the main table of contents; the ``on this page'' box that
@@ -541,7 +549,8 @@ sub-parts).
The @racket[parts] field contains sub-parts.
@history[#:changed "1.25" @elem{Added @racket['no-index] support.}
- #:changed "1.26" @elem{Added @racket[link-render-style] support.}]}
+ #:changed "1.26" @elem{Added @racket[link-render-style] support.}
+ #:changed "1.27" @elem{Added @racket['no-toc+aux] support.}]}
@defstruct[paragraph ([style style?] [content content?])]{
diff --git a/scribble-lib/info.rkt b/scribble-lib/info.rkt
index d23ca4de..befc200e 100644
--- a/scribble-lib/info.rkt
+++ b/scribble-lib/info.rkt
@@ -23,4 +23,4 @@
(define pkg-authors '(mflatt eli))
-(define version "1.31")
+(define version "1.32")
diff --git a/scribble-lib/scribble/html-render.rkt b/scribble-lib/scribble/html-render.rkt
index 9c983baa..fb335599 100644
--- a/scribble-lib/scribble/html-render.rkt
+++ b/scribble-lib/scribble/html-render.rkt
@@ -905,7 +905,9 @@
(head-extra-xexpr p)))
(body ([id ,(or (extract-part-body-id d ri)
"scribble-racket-lang-org")])
- ,@(render-toc-view d ri)
+ ,@(if (part-style? d 'no-toc+aux)
+ null
+ (render-toc-view d ri))
(div ([class "maincolumn"])
(div ([class "main"])
,@(parameterize ([current-version (extract-version d)])
From 84607f796c35f7c0849d29cb6eb65819d8a0855d Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 8 Dec 2019 09:49:47 -0700
Subject: [PATCH 14/17] fix 'hidden style property for main document title
---
scribble-lib/scribble/latex-render.rkt | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/scribble-lib/scribble/latex-render.rkt b/scribble-lib/scribble/latex-render.rkt
index 6eeb8663..b1c966da 100644
--- a/scribble-lib/scribble/latex-render.rkt
+++ b/scribble-lib/scribble/latex-render.rkt
@@ -151,7 +151,9 @@
(install-file style-file))))
(when whole-doc?
(printf "\\begin{document}\n\\preDoc\n")
- (when (part-title-content d)
+ (when (and (part-title-content d)
+ (not (and (part-style? d 'hidden)
+ (equal? "" (content->string (part-title-content d))))))
(let ([vers (extract-version d)]
[date (extract-date d)]
[pres (extract-pretitle-content d)]
@@ -166,7 +168,6 @@
(do-render-nested-flow pre d ri #t #f #t)]))
(when date (printf "\\date{~a}\n" date))
(printf "\\titleAnd~aVersionAnd~aAuthors~a{"
-
(if (equal? vers "") "Empty" "")
(if (null? auths) "Empty" "")
(if short "AndShort" ""))
From 08d09d672e132d654202f764d1a3586030a7d9b7 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 8 Dec 2019 10:06:04 -0700
Subject: [PATCH 15/17] docs: remove wrong claims about `body-id`
The `body-id` structure is actually only recognized in a main `part`.
for other places, use `attributes`.
---
scribble-doc/scribblings/scribble/core.scrbl | 21 +-------------------
1 file changed, 1 insertion(+), 20 deletions(-)
diff --git a/scribble-doc/scribblings/scribble/core.scrbl b/scribble-doc/scribblings/scribble/core.scrbl
index ba512a4e..95b05936 100644
--- a/scribble-doc/scribblings/scribble/core.scrbl
+++ b/scribble-doc/scribblings/scribble/core.scrbl
@@ -599,10 +599,6 @@ The currently recognized @tech{style properties} are as follows:
@item{@racket[attributes] structure --- Provides additional HTML
attributes for the @tt{<p>}, @tt{<div>}, or alternate tag.}
- @item{@racket[body-id] structure --- For HTML, uses the given string
- as an @tt{id} attribute of the @tt{<p>}, @tt{<div>}, or
- alternate tag.}
-
@item{@indexed-racket['never-indents] --- For Latex and @tech{compound
paragraphs}; see @racket[compound-paragraph].}
@@ -658,9 +654,6 @@ The following @tech{style properties} are currently recognized:
@item{@racket[attributes] structure --- Provides additional HTML
attributes for the @tt{<table>} tag.}
- @item{@racket[body-id] structure --- For HTML, uses the given string
- as an @tt{id} attribute of the @tt{<table>} tag.}
-
@item{@indexed-racket['aux] --- For HTML, include the table in the
table-of-contents display for the enclosing part.}
@@ -707,9 +700,6 @@ The following @tech{style properties} are currently recognized:
@item{@racket[attributes] structure --- Provides additional HTML
attributes for the @tt{<ul>} or @tt{<ol>} tag.}
- @item{@racket[body-id] structure --- For HTML, uses the given string
- as an @tt{id} attribute of the @tt{<ul>} or @tt{<ol>} tag.}
-
@item{@indexed-racket['never-indents] --- For Latex and @tech{compound
paragraphs}; see @racket[compound-paragraph].}
@@ -758,9 +748,6 @@ The following @tech{style properties} are currently recognized:
@item{@racket[attributes] structure --- Provides additional HTML
attributes for the @tt{<blockquote>} tag.}
- @item{@racket[body-id] structure --- For HTML, uses the given string
- as an @tt{id} attribute of the @tt{<blockquote>} tag.}
-
@item{@indexed-racket['never-indents] --- For Latex and @tech{compound
paragraphs}; see @racket[compound-paragraph].}
@@ -811,9 +798,6 @@ for Latex output (see @secref["extra-style"]). The following
@item{@racket[attributes] structure --- Provides additional HTML
attributes for the @tt{<p>} or alternate tag.}
- @item{@racket[body-id] structure --- For HTML, uses the given string
- as an @tt{id} attribute of the @tt{<p>} or alternate tag.}
-
@item{@indexed-racket['never-indents] --- For Latex within another
@tech{compound paragraph}; see above.}
@@ -923,9 +907,6 @@ The following @tech{style properties} are currently recognized:
@item{@racket[xexpr-property] structure --- For HTML, supplies literal
HTML to render before and after @racket[content].}
- @item{@racket[body-id] structure --- For HTML uses the given
- string as an @tt{id} attribute of the @tt{<span>} tag.}
-
@item{@indexed-racket['aux] --- Intended for use in titles, where the
auxiliary part of the title can be omitted in hyperlinks. See,
for example, @racket[secref].}
@@ -1827,7 +1808,7 @@ Like @racket[css-style-addition], but for a JavaScript file instead of a CSS fil
@defstruct[body-id ([value string?])]{
Used as a @tech{style property} to associate an @tt{id} attribute with
-an HTML tag.}
+an HTML tag within a main @racket[part].}
@defstruct[document-source ([module-path module-path?])]{
From 0fd2444634223bac2837e52ed1eed57824791c9c Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 15 Dec 2019 10:06:52 -0700
Subject: [PATCH 16/17] make search box first in focus order
Closes racket/racket#2953
---
scribble-lib/scribble/html-render.rkt | 1 +
1 file changed, 1 insertion(+)
diff --git a/scribble-lib/scribble/html-render.rkt b/scribble-lib/scribble/html-render.rkt
index fb335599..fefb285b 100644
--- a/scribble-lib/scribble/html-render.rkt
+++ b/scribble-lib/scribble/html-render.rkt
@@ -226,6 +226,7 @@
([class "searchbox"]
[style ,(sa "color: "dimcolor";")]
[type "text"]
+ [tabindex "1"]
[value ,emptylabel]
[title "Enter a search string to search the manuals"]
[onkeypress ,(format "return DoSearchKey(event, this, ~s, ~s);"
From ed02550d1a8a43873892bc8f4b63f33a0faaac0b Mon Sep 17 00:00:00 2001
From: Alexis King <lexi.lambda@gmail.com>
Date: Thu, 2 Jan 2020 12:32:45 -0600
Subject: [PATCH 17/17] Fix the contracts on `exec`/`commandline` to match
their behavior
---
scribble-doc/scribblings/scribble/manual.scrbl | 7 +++----
scribble-lib/scribble/private/manual-style.rkt | 7 ++++---
2 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/scribble-doc/scribblings/scribble/manual.scrbl b/scribble-doc/scribblings/scribble/manual.scrbl
index dda1ebe0..b7a8fd96 100644
--- a/scribble-doc/scribblings/scribble/manual.scrbl
+++ b/scribble-doc/scribblings/scribble/manual.scrbl
@@ -1714,9 +1714,8 @@ Typesets the given combination of a GUI's menu and item name.}
@tech{decode}d @racket[pre-content] as a file name (e.g., in
typewriter font and in quotes).}
-@defproc[(exec [pre-content pre-content?] ...) element?]{Typesets the
-@tech{decode}d @racket[pre-content] as a command line (e.g., in
-typewriter font).}
+@defproc[(exec [content content?] ...) element?]{Typesets the
+@racket[content] as a command line (e.g., in typewriter font).}
@defproc[(envvar [pre-content pre-content?] ...) element?]{Typesets the given
@tech{decode}d @racket[pre-content] as an environment variable (e.g.,
@@ -2028,7 +2027,7 @@ that is hyperlinked to an explanation.}
@defthing[undefined-const element?]{Returns an element for @|undefined-const|.}
-@defproc[(commandline [pre-content pre-content?] ...) paragraph?]{Produces
+@defproc[(commandline [content content?] ...) paragraph?]{Produces
an inset command-line example (e.g., in typewriter font).}
@defproc[(inset-flow [pre-flow pre-flow?] ...) nested-flow?]{
diff --git a/scribble-lib/scribble/private/manual-style.rkt b/scribble-lib/scribble/private/manual-style.rkt
index 2d64e11d..e7d12f4b 100644
--- a/scribble-lib/scribble/private/manual-style.rkt
+++ b/scribble-lib/scribble/private/manual-style.rkt
@@ -4,7 +4,7 @@
"../base.rkt"
(only-in "../basic.rkt" aux-elem itemize)
"../scheme.rkt"
- (only-in "../core.rkt" make-style plain
+ (only-in "../core.rkt" content? make-style plain
make-nested-flow nested-flow? box-mode box-mode*
[element? core:element?])
"manual-utils.rkt"
@@ -31,7 +31,7 @@
(provide-styling racketmodfont racketoutput
racketerror racketfont racketplainfont racketvalfont racketidfont racketvarfont
racketcommentfont racketparenfont racketkeywordfont racketmetafont
- onscreen defterm filepath exec envvar Flag DFlag PFlag DPFlag math
+ onscreen defterm filepath envvar Flag DFlag PFlag DPFlag math
procedure
indexed-file indexed-envvar idefterm pidefterm)
(provide
@@ -59,7 +59,8 @@
[inset-flow (() () #:rest (listof pre-content?) . ->* . nested-flow?)]
[litchar (() () #:rest (listof string?) . ->* . element?)]
[t (() () #:rest (listof pre-content?) . ->* . paragraph?)]
- [commandline (() () #: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")))