Skip to content

WIP: add option to output xexpr of html #498

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 5 commits into
base: master
Choose a base branch
from
Open

WIP: add option to output xexpr of html #498

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
8cb44e5
Add option to output xexpr of html
stevebyan Apr 16, 2025
aa6ab9e
Replace fmt with pretty-write
stevebyan Apr 27, 2025
9db1a06
remove extraneous whitespace
stevebyan Apr 28, 2025
55ca2ae
Resyntax if-let-to-cond
stevebyan Apr 28, 2025
0233376
Remove unused require
stevebyan Apr 28, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 2 additions & 1 deletion scribble-lib/scribble/base-render.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -57,7 +57,8 @@
[extra-files null]
[image-preferences null]
[helper-file-prefix #f]
[keep-existing-helper-files? #f])
[keep-existing-helper-files? #f]
[xexpr-out? #f])

(define/public (current-render-mode)
'())
Expand Down
302 changes: 278 additions & 24 deletions scribble-lib/scribble/html-render.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,7 @@
racket/path
racket/file
racket/port
racket/pretty
racket/list
racket/string
file/convertible
Expand All @@ -28,6 +29,16 @@
(provide render-mixin
render-multi-mixin)

(struct scribble-xexpr-page
(title ; string?
author ; string?
date ; string? - 8601 datetime format
version ; string? version number
tags ; (listof string?)
tocset ; (list?)
article ; xexpr?
) #:prefab)

(define (number->decimal-string s)
(number->string (if (integer? s) s (exact->inexact s))))

Expand Down Expand Up @@ -273,9 +284,10 @@
extract-part-style-files
extract-version
extract-authors
extract-date
extract-pretitle
link-render-style-at-element)
(inherit-field prefix-file style-file style-extra-files image-preferences)
(inherit-field prefix-file style-file style-extra-files image-preferences xexpr-out?)

(init-field [alt-paths null]
;; `up-path' is either a link "up", or #t which goes
Expand All @@ -290,7 +302,10 @@
(define/override (current-render-mode)
'(html))

(define/override (get-suffix) #".html")
(define/override (get-suffix)
(if xexpr-out?
#".rktd"
#".html"))

(define/override (index-manual-newlines?)
#t)
Expand Down Expand Up @@ -564,6 +579,102 @@
(define/public (render-top ds fns ri)
(super render ds fns ri))

(define/public (list-of-toc-view d ri)
(define has-sub-parts?
(pair? (part-parts d)))
(define sub-parts-on-other-page?
(and has-sub-parts?
(part-whole-page? (car (part-parts d)) ri)))
(define toc-chain
(let loop ([d d] [r (if has-sub-parts? (list d) '())])
(cond [(collected-info-parent (part-collected-info d ri))
=> (lambda (p) (loop p (cons p r)))]
[(pair? r) r]
;; we have no toc, so use just the current part
[else (list d)])))
(define top (car toc-chain))
(define (toc-item->title+num t show-mine?)
(values
(dest->url (resolve-get t ri (car (part-tags/nonempty t))))
(if (or (eq? t d) (and show-mine? (memq t toc-chain)))
"tocviewselflink"
"tocviewlink")
(render-content (strip-aux (or (part-title-content t) '("???"))) d ri)
(format-number (collected-info-number (part-collected-info t ri))
null)))
(define (toc-item->block t i)
(define-values (url linktype title num) (toc-item->title+num t #f))
(define children ; note: might be empty
(filter (lambda (p) (not (part-style? p 'toc-hidden)))
(part-parts t)))
(define id (format "tocview_~a" i))
(define last? (eq? t (last toc-chain)))
(define expand? (or (and last?
(or (not has-sub-parts?)
sub-parts-on-other-page?))
(and has-sub-parts?
(not sub-parts-on-other-page?)
;; next-to-last?
(let loop ([l toc-chain])
(cond
[(null? l) #f]
[(eq? t (car l))
(and (pair? (cdr l)) (null? (cddr l)))]
[else (loop (cdr l))])))))
(define top? (eq? t top))
(define header (list num title))
(list
(if top?
"tocviewlist tocviewlisttopspace"
"tocviewlist")
(if top? (list "tocviewtitle" header) header)
(if (null? children)
""
(list (list
(cond
[(and top? last?) "tocviewsublistonly"]
[top? "tocviewsublisttop"]
[last? "tocviewsublistbottom"]
[else "tocviewsublist"])
(if expand? 'block 'none)
id)
(for/list ([c children])
(let-values ([(u l t n) (toc-item->title+num c #t)])
(list n u l t)))))))
(define (toc-content)
;; no links -- the code constructs links where needed
(parameterize ([current-no-links #t]
[extra-breaking? #t])
(for/list ([t toc-chain] [i (in-naturals)])
(toc-item->block t i))))
(list
"tocset"
(if (part-style? d 'no-toc)
null
;; toc-wrap determines if we get the toc or just the title !!!
(toc-content))
(if (part-style? d 'no-sidebar)
null
(list-of-onthispage-contents
d ri top (if (part-style? d 'no-toc) "tocview" "tocsub")
sub-parts-on-other-page?))
(parameterize ([extra-breaking? #t])
(append-map (lambda (e)
(let loop ([e e])
(cond
[(and (table? e)
(memq 'aux (style-properties (table-style e)))
(pair? (table-blockss e)))
(render-table e d ri #f)]
[(delayed-block? e)
(loop (delayed-block-blocks e ri))]
[(traverse-block? e)
(loop (traverse-block-block e ri))]
[(compound-paragraph? e)
(append-map loop (compound-paragraph-blocks e))]
[else null])))
(part-blocks d)))))

(define/public (render-toc-view d ri)
(define has-sub-parts?
(pair? (part-parts d)))
Expand Down Expand Up @@ -688,6 +799,115 @@
(hash-set! hidden-memo p h?)
h?)))

(define/private (list-of-onthispage-contents d ri top box-class sections-in-toc?)
(let ([nearly-top? (lambda (d)
;; If ToC would be collapsed, then
;; no section is nearly the top
(if (not sections-in-toc?)
#f
(nearly-top? d ri top)))])
(define (flow-targets flow)
(append-map block-targets flow))
(define (block-targets e)
(cond [(table? e) (table-targets e)]
[(paragraph? e) (para-targets e)]
[(itemization? e)
(append-map flow-targets (itemization-blockss e))]
[(nested-flow? e)
(append-map block-targets (nested-flow-blocks e))]
[(compound-paragraph? e)
(append-map block-targets (compound-paragraph-blocks e))]
[(delayed-block? e) null]
[(traverse-block? e) (block-targets (traverse-block-block e ri))]))
(define (para-targets para)
(let loop ([a (paragraph-content para)])
(cond
[(list? a) (append-map loop a)]
[(toc-target-element? a) (list a)]
[(toc-element? a) (list a)]
[(element? a) (loop (element-content a))]
[(delayed-element? a) (loop (delayed-element-content a ri))]
[(traverse-element? a) (loop (traverse-element-content a ri))]
[(part-relative-element? a) (loop (part-relative-element-content a ri))]
[else null])))
(define (table-targets table)
(append-map
(lambda (blocks)
(append-map (lambda (f) (if (eq? f 'cont) null (block-targets f)))
blocks))
(table-blockss table)))
(define ps
((if (or (nearly-top? d) (eq? d top)) values (lambda (p) (if (pair? p) (cdr p) null)))
(let flatten ([d d] [prefixes null] [top? #t])
(let ([prefixes (if (and (not top?) (part-tag-prefix-string d))
(cons (part-tag-prefix-string d) prefixes)
prefixes)])
(append*
;; don't include the section if it's in the TOC
(if (or (nearly-top? d)
(part-style? d 'toc-hidden))
null
(list (vector d prefixes d)))
;; get internal targets:
(map (lambda (v) (vector v prefixes d)) (append-map block-targets (part-blocks d)))
(map (lambda (p) (if (or (part-whole-page? p ri)
(and (part-style? p 'toc-hidden)
(all-toc-hidden? p)))
null
(flatten p prefixes #f)))
(part-parts d)))))))
Comment on lines +853 to +858
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

map-to-for: This map operation can be replaced with a for/list loop.

Suggested change
(map (lambda (p) (if (or (part-whole-page? p ri)
(and (part-style? p 'toc-hidden)
(all-toc-hidden? p)))
null
(flatten p prefixes #f)))
(part-parts d)))))))
(for/list ([p (in-list (part-parts d))])
(if (or (part-whole-page? p ri)
(and (part-style? p 'toc-hidden) (all-toc-hidden? p)))
null
(flatten p prefixes #f))))))))
Debugging details
Textual replacement 
(line-replacement
  #:new-lines
    '#("                  (for/list ([p (in-list (part-parts d))])"
       "                    (if (or (part-whole-page? p ri)"
       "                            (and (part-style? p 'toc-hidden) (all-toc-hidden? p)))"
       "                        null"
       "                        (flatten p prefixes #f))))))))")
  #:original-lines
    '#("                  (map (lambda (p) (if (or (part-whole-page? p ri) "
       "                                           (and (part-style? p 'toc-hidden)"
       "                                                (all-toc-hidden? p)))"
       "                                       null"
       "                                       (flatten p prefixes #f)))"
       "                       (part-parts d)))))))")
  #:start-line 854)
Syntactic replacement 
(syntax-replacement
  #:introduction-scope #<procedure:...and/syntax-local.rkt:148:2>
  #:new-syntax
    #<syntax:/home/runner/.local/share/racket/8.17.0.1/pkgs/resyntax/default-recommendations/for-loop-shortcuts.rkt:149:2 (for/list ((p (in-list (part-parts d)))) (if (or (part-whole-page? p ri) (and (part-style? p (quote toc-hidden)) (all-toc-hidden? p))) null (flatten p prefixes #f)))>
  #:original-syntax
    #<syntax:scribble-lib/scribble/html-render.rkt:854:18 (map (lambda (p) (if (or (part-whole-page? p ri) (and (part-style? p (quote toc-hidden)) (all-toc-hidden? p))) null (flatten p prefixes #f))) (part-parts d))>
  #:source
    (file-source
     #<path:/home/runner/work/scribble/scribble/scribble-lib/scribble/html-render.rkt>))

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I’d prefer not to change any pre-existing logic in this commit, unless mflatt requests it.

(define any-parts? (ormap (compose part? (lambda (p) (vector-ref p 0))) ps))
(if (null? ps)
null
(list
(get-onthispage-label)
"tocsublist"
(map (lambda (p)
(let ([p (vector-ref p 0)]
[prefixes (vector-ref p 1)]
[from-d (vector-ref p 2)]
[add-tag-prefixes
(lambda (t prefixes)
(if (null? prefixes)
t
(cons (car t) (append prefixes (cdr t)))))])
(list
(if (part? p)
(format-number
(collected-info-number
(part-collected-info p ri))
null)
null)
(if (toc-element? p)
(render-content (toc-element-toc-content p)
from-d ri)
(parameterize ([current-no-links #t]
[extra-breaking? #t])
(list
(uri-unreserved-encode
(anchor-name
(add-tag-prefixes
(tag-key (if (part? p)
(car (part-tags/nonempty p))
(target-element-tag p))
ri)
prefixes)))
(cond
[(part? p) "tocsubseclink"]
[any-parts? "tocsubnonseclink"]
[else "tocsublink"])

(render-content
(if (part? p)
(strip-aux
(or (part-title-content p)
"???"))
(if (toc-target2-element? p)
(toc-target2-element-toc-content p)
(element-content p)))
from-d ri)))))))
ps)))))
Comment on lines +865 to +909
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

map-to-for: This map operation can be replaced with a for/list loop.

Suggested change
(map (lambda (p)
(let ([p (vector-ref p 0)]
[prefixes (vector-ref p 1)]
[from-d (vector-ref p 2)]
[add-tag-prefixes
(lambda (t prefixes)
(if (null? prefixes)
t
(cons (car t) (append prefixes (cdr t)))))])
(list
(if (part? p)
(format-number
(collected-info-number
(part-collected-info p ri))
null)
null)
(if (toc-element? p)
(render-content (toc-element-toc-content p)
from-d ri)
(parameterize ([current-no-links #t]
[extra-breaking? #t])
(list
(uri-unreserved-encode
(anchor-name
(add-tag-prefixes
(tag-key (if (part? p)
(car (part-tags/nonempty p))
(target-element-tag p))
ri)
prefixes)))
(cond
[(part? p) "tocsubseclink"]
[any-parts? "tocsubnonseclink"]
[else "tocsublink"])
(render-content
(if (part? p)
(strip-aux
(or (part-title-content p)
"???"))
(if (toc-target2-element? p)
(toc-target2-element-toc-content p)
(element-content p)))
from-d ri)))))))
ps)))))
(for/list ([p (in-list ps)])
(let ([p (vector-ref p 0)]
[prefixes (vector-ref p 1)]
[from-d (vector-ref p 2)]
[add-tag-prefixes (lambda (t prefixes)
(if (null? prefixes)
t
(cons (car t) (append prefixes (cdr t)))))])
(list (if (part? p)
(format-number (collected-info-number (part-collected-info p ri)) null)
null)
(if (toc-element? p)
(render-content (toc-element-toc-content p) from-d ri)
(parameterize ([current-no-links #t]
[extra-breaking? #t])
(list (uri-unreserved-encode
(anchor-name (add-tag-prefixes
(tag-key (if (part? p)
(car (part-tags/nonempty p))
(target-element-tag p))
ri)
prefixes)))
(cond
[(part? p) "tocsubseclink"]
[any-parts? "tocsubnonseclink"]
[else "tocsublink"])
(render-content (if (part? p)
(strip-aux (or (part-title-content p) "???"))
(if (toc-target2-element? p)
(toc-target2-element-toc-content p)
(element-content p)))
from-d
ri)))))))))))
Debugging details
Textual replacement 
(line-replacement
  #:new-lines
    '#("               (for/list ([p (in-list ps)])"
       "                 (let ([p (vector-ref p 0)]"
       "                       [prefixes (vector-ref p 1)]"
       "                       [from-d (vector-ref p 2)]"
       "                       [add-tag-prefixes (lambda (t prefixes)"
       "                                           (if (null? prefixes)"
       "                                               t"
       "                                               (cons (car t) (append prefixes (cdr t)))))])"
       "                   (list (if (part? p)"
       "                             (format-number (collected-info-number (part-collected-info p ri)) null)"
       "                             null)"
       "                         (if (toc-element? p)"
       "                             (render-content (toc-element-toc-content p) from-d ri)"
       "                             (parameterize ([current-no-links #t]"
       "                                            [extra-breaking? #t])"
       "                               (list (uri-unreserved-encode"
       "                                      (anchor-name (add-tag-prefixes"
       "                                                    (tag-key (if (part? p)"
       "                                                                 (car (part-tags/nonempty p))"
       "                                                                 (target-element-tag p))"
       "                                                             ri)"
       "                                                    prefixes)))"
       "                                     (cond"
       "                                       [(part? p) \"tocsubseclink\"]"
       "                                       [any-parts? \"tocsubnonseclink\"]"
       "                                       [else \"tocsublink\"])"
       "                                     (render-content (if (part? p)"
       "                                                         (strip-aux (or (part-title-content p) \"???\"))"
       "                                                         (if (toc-target2-element? p)"
       "                                                             (toc-target2-element-toc-content p)"
       "                                                             (element-content p)))"
       "                                                     from-d"
       "                                                     ri)))))))))))")
  #:original-lines
    '#("               (map (lambda (p)"
       "                      (let ([p (vector-ref p 0)]"
       "                            [prefixes (vector-ref p 1)]"
       "                            [from-d (vector-ref p 2)]"
       "                            [add-tag-prefixes"
       "                             (lambda (t prefixes)"
       "                               (if (null? prefixes)"
       "                                   t"
       "                                   (cons (car t) (append prefixes (cdr t)))))])"
       "                        (list"
       "                         (if (part? p)"
       "                             (format-number"
       "                              (collected-info-number"
       "                               (part-collected-info p ri))"
       "                              null)"
       "                             null)"
       "                         (if (toc-element? p)"
       "                             (render-content (toc-element-toc-content p)"
       "                                             from-d ri)"
       "                             (parameterize ([current-no-links #t]"
       "                                            [extra-breaking? #t])"
       "                               (list "
       "                                (uri-unreserved-encode"
       "                                 (anchor-name"
       "                                  (add-tag-prefixes"
       "                                   (tag-key (if (part? p)"
       "                                                (car (part-tags/nonempty p))"
       "                                                (target-element-tag p))"
       "                                            ri)"
       "                                   prefixes)))"
       "                                (cond"
       "                                  [(part? p) \"tocsubseclink\"]"
       "                                  [any-parts? \"tocsubnonseclink\"]"
       "                                  [else \"tocsublink\"])"
       "                                        "
       "                                (render-content"
       "                                 (if (part? p)"
       "                                     (strip-aux"
       "                                      (or (part-title-content p)"
       "                                          \"???\"))"
       "                                     (if (toc-target2-element? p)"
       "                                         (toc-target2-element-toc-content p)"
       "                                         (element-content p)))"
       "                                 from-d ri)))))))"
       "                    ps)))))")
  #:start-line 866)
Syntactic replacement 
(syntax-replacement
  #:introduction-scope #<procedure:...and/syntax-local.rkt:148:2>
  #:new-syntax
    #<syntax:/home/runner/.local/share/racket/8.17.0.1/pkgs/resyntax/default-recommendations/for-loop-shortcuts.rkt:149:2 (for/list ((p (in-list ps))) (let ((p (vector-ref p 0)) (prefixes (vector-ref p 1)) (from-d (vector-ref p 2)) (add-tag-prefixes (lambda (t prefixes) (if (null? prefixes) t (cons (car t) (append prefixes (cdr t))))))) (list (if (part? p) (format-number (...>
  #:original-syntax
    #<syntax:scribble-lib/scribble/html-render.rkt:866:15 (map (lambda (p) (let ((p (vector-ref p 0)) (prefixes (vector-ref p 1)) (from-d (vector-ref p 2)) (add-tag-prefixes (lambda (t prefixes) (if (null? prefixes) t (cons (car t) (append prefixes (cdr t))))))) (list (if (part? p) (format-number (collected-in...>
  #:source
    (file-source
     #<path:/home/runner/work/scribble/scribble/scribble-lib/scribble/html-render.rkt>))

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I’d prefer not to change any pre-existing logic in this commit, unless mflatt requests it.


(define/private (render-onthispage-contents d ri top box-class sections-in-toc?)
(let ([nearly-top? (lambda (d)
;; If ToC would be collapsed, then
Expand Down Expand Up @@ -846,6 +1066,10 @@
`(title ,@(format-number number '(nbsp))
,(content->string (strip-aux c) this d ri)))]
[else `(title)])]
[title-string (cond [(part-title-content d)
=> (lambda (c)
(content->string (strip-aux c) this d ri))]
[else null])]
[dir-depth (part-nesting-depth d ri)]
[extract (lambda (pred get) (extract-part-style-files
d
Expand All @@ -863,16 +1087,16 @@
(define script-file-path
(or (lookup-path script-file alt-paths)
(install-file/as-url script-file)))
(if (bytes? prefix-file)
(unless xexpr-out?
(if (bytes? prefix-file)
(display prefix-file)
(call-with-input-file*
prefix-file
(lambda (in)
(copy-port in (current-output-port)))))
(copy-port in (current-output-port))))))
(parameterize ([xml:empty-tag-shorthand xml:html-empty-tags])
(xml:write-xexpr
`(html ,(style->attribs (part-style d))
(head ()
(define head-xexpr
`(head ()
(meta ([http-equiv "content-type"]
[content "text/html; charset=utf-8"]))
(meta ([name "viewport"]
Expand Down Expand Up @@ -908,20 +1132,50 @@
,@(extract head-addition? head-addition-xexpr)
,@(for/list ([p (style-properties (part-style d))]
#:when (head-extra? p))
(head-extra-xexpr p)))
(body ([id ,(or (extract-part-body-id d ri)
"scribble-racket-lang-org")])
,@(if (part-style? d 'no-toc+aux)
null
(render-toc-view d ri))
(div ([class "maincolumn"])
(head-extra-xexpr p))))
(define content-xexpr (render-part d ri))
(define main-xexpr
`(div ([class "maincolumn"])
(div ([class "main"])
,@(parameterize ([current-version (extract-version d)])
(render-version d ri))
,@(navigation d ri #t)
,@(render-part d ri)
,@(navigation d ri #f)))
(div ([id "contextindicator"]) nbsp))))))))
,@content-xexpr
,@(navigation d ri #f))))
(define body-xexpr
`(body ([id ,(or (extract-part-body-id d ri)
"scribble-racket-lang-org")])
,@(if (part-style? d 'no-toc+aux)
null
(render-toc-view d ri))
,main-xexpr
(div ([id "contextindicator"]) nbsp)))
(define part-xexpr
`(html ,(style->attribs (part-style d))
,head-xexpr
,body-xexpr))
(define article-xexpr
`(article ([class "document"])
,@content-xexpr))
(define (authors-list)
(define authors-paragraph-list (extract-authors d))
(for/list ([p authors-paragraph-list])
(car (paragraph-content p))))
(cond
[xexpr-out?
(pretty-write
(scribble-xexpr-page
title-string ; title
(authors-list) ; authors
(extract-date d) ; date
(extract-version d) ; document version
null ; tags
(if (part-style? d 'no-toc+aux)
null
(list-of-toc-view d ri)) ; tocset
article-xexpr ; article
))]
[else (xml:write-xexpr part-xexpr)])))))

(define (toc-part? d ri)
(and (part-style? d 'toc)
Expand Down Expand Up @@ -1190,13 +1444,13 @@
[class "heading-anchor"]
[title "Link to here"])
"🔗"))])
,@(if (and src taglet)
(list '(a ([class "heading-source"]
[title "Internal Scribble link and Scribble source"]) "ℹ"))
'())
;; this is a dummy node so that the line height of heading-anchor
;; and heading-source are correct (even when their font size is not 100%)
(span ([style "visibility: hidden"]) " "))))])
,@(if (and src taglet)
(list '(a ([class "heading-source"]
[title "Internal Scribble link and Scribble source"]) "ℹ"))
'())
;; this is a dummy node so that the line height of heading-anchor
;; and heading-source are correct (even when their font size is not 100%)
(span ([style "visibility: hidden"]) " "))))])
,@(let ([auths (extract-authors d)])
(if (null? auths)
null
Expand Down
Loading