#lang racket/base
; SPDX-License-Identifier: BlueOak-1.0.0
; This file is licensed under the Blue Oak Model License 1.0.0.
;; Renders a Yarn AST and metadata into HTML
(require "../tools.rkt"
"../string.rkt"
"../path.rkt"
koyo/haml
pollen/core
pollen/decode
racket/function
racket/list
racket/match
racket/string
txexpr)
(provide doc->html)
;; TODO: most of this should all go into the template code
(define (doc->html doc)
(define-values (title-type class)
(if (meta-set? 'title-supplied?)
(values 'given "with-title")
(values 'generated "no-title")))
(haml
(:article.h-entry
[[:class class]]
,@(heading/permlink title-type)
(:section.entry-content
,@(decode-elements #:block-txexpr-proc render-block
#:inline-txexpr-proc render-inline
(cdr doc))))))
;; TODO: This should really go into the template code
(define (heading/permlink title-type)
(define m (current-metas))
(define p (hash-ref m 'published))
(case title-type
[(given)
(haml
(:h1.entry-title ,@(hash-ref m 'title))
(:p.time
(:a.rel-bookmark
[[:href (string-append "/" (here-output-path))]]
(:time.published [[:datetime p]] (ymd->english p)))))]
[(generated)
(haml
(:h1
(:a.rel-bookmark
[[:href (string-append "/" (here-output-path))]]
(:time.entry-title [[:datetime p]] (ymd->english p)))))]))
;; Block-Content :=
;; ✅ (heading level Inline-Contents)
;; | ✅ (paragraph Inline-Contents)
;; | ✅ (thematic-break style)
;; | ✅ (codeblock info Inline-Contents)
;; | ✅ (blockquote items := (item Block-Contents))
;; | ✅ (poetry title style Block-Contents)
;; | ✅ (itemization style start Block-Contents)
;; | ✅ (dialogue speeches := (speech interlocutor Block-Contents))
;; | ✅ (figure source caption)
;; | (margin-note Block-Contents)
(define (render-block e)
(match e
[(list 'heading (list (list 'level lev)) elems ...) (render-heading lev elems)]
[(list 'paragraph elems ...) `(p ,@elems)]
[(list 'thematic-break style) `(hr [[class ,style]])]
[(list 'blockquote elems ...) `(blockquote ,@elems)]
[(txexpr 'poetry attrs elems) (render-poetry attrs elems)]
[(txexpr 'codeblock attrs elems) (render-codeblock attrs elems)]
[(txexpr 'itemization attrs elems) (render-itemization attrs elems)]
[(txexpr 'dialogue _ elems) `(dl ,@elems)]
[(list 'speech interlocutor elems ...)
`(@ (dt ,interlocutor (span [[class "x"]] ": ")) (dd ,@elems))]
[(txexpr 'figure attrs elems) (render-figure (car elems) (cdr elems))]
[else (raise-argument-error 'render-block "block-content" e)]))
;; Inline-Content :=
;; string?
;; | ✅ (italic Inline-Contents)
;; | ✅ (bold Inline-Contents)
;; | ✅ (link destination Inline-Contents)
;; | ✅ (monospace Inline-Contents)
;; | ✅ (strikethrough Inline-Contents)
;; | ✅ (caps Inline-Contents)
;; | (image description source)
;; | ✅ (xref type dest-key Inline-Contents)
;; | ✅ (footnote-ref label)
;; | line-break
(define (render-inline e)
(match e
[(list 'italic elems ...) `(i ,@elems)]
[(list 'bold elems ...) `(b ,@elems)]
[(list 'monospace elems ...) `(samp ,@elems)]
[(list 'strikethrough elems ...) `(del ,@elems)]
[(list 'caps elems ...) `(span [[class "caps"]] ,@elems)]
[(list 'link dest elems ...) (render-link dest elems)]
[(list 'xref type key elems ...) (render-xref type key elems)]
[(list 'footnote-ref ref) (render-footnote-ref ref)]
[(list 'item elems ...) `(li ,@elems)]
[else e]))
(define (render-link dest elems)
(define url
(or (get-metas-subhash 'urls dest)
(format "#Missing_Reference_~a" dest)))
`(a [[href ,url]] ,@elems))
(define (render-heading level elems)
(define tag (string->symbol (format "h~a" level)))
`(,tag ,@elems))
(define (render-poetry attrs elems)
(define title
(match (attr-ref attrs 'title attrs #f)
[(? string? t) `(p [[class "verse-heading"]] ,t)]
[_ ""]))
(define pre-attrs
(cond
[(string-contains? (attr-ref attrs 'style "") "italic")
'((style "font-style: italic"))]
[else '()]))
`(div [[class "poem"]] ,title (pre [[class "verse"] ,@pre-attrs] ,@elems)))
(define (render-codeblock attrs elems)
(define file (or (assoc 'filename attrs) ""))
(define codeblock `(pre [[class "code"]] (code ,@elems)))
(cond [(non-empty-string? file) `(@ (div [[class "listing-filename"]] 128196 " " ,file) ,codeblock)]
[else codeblock]))
(define (render-itemization attrs elems)
(define tag (if (attr-ref attrs 'start #f) 'ol 'ul))
`(,tag ,attrs ,@elems))
(define (render-figure source elems)
`(figure [[class "fullwidth"]]
(img [[src ,source]] [[alt ,(->text elems)]])
(figcaption ,@elems)))
;; The AST guarantees that they key will already be URI-safe
(define (render-xref type key elems)
`(a [[id ,(here-key (format "_~a-~a" type key))]
[href ,(string-append "/keyword-index.html#" key)] ; TODO: ref type links need to resolve to the target
[data-index-entry ,key]
[class ,(symbol->string type)]]
,@elems))
(define (render-footnote-ref ref)
(cons-to-metas-list 'fn-names ref)
(let* ([here (here-key)]
[fn-names (hash-ref (current-metas) 'fn-names)]
[def-anchor (format "#~a_fndef_~a" here ref)]
[nth-ref (number->string (count (curry equal? ref) fn-names))]
[ref-id (format "#~a_fn_~a_~a" here ref nth-ref)]
[fn-number (+ 1 (index-of (remove-duplicates (reverse fn-names)) ref))]
[ref-text (format "(~a)" fn-number)])
`(sup (a [[href ,def-anchor] [id ,ref-id]] ,ref-text))))
