You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/quad/qtest/markdown.rkt

443 lines
20 KiB
Racket

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

This file contains ambiguous Unicode characters that may be confused with others in your current locale. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to highlight these characters.

#lang debug racket/base
(require (for-syntax racket/base) txexpr racket/runtime-path racket/string racket/promise racket/match racket/list
pitfall quad sugar/debug pollen/tag racket/unsafe/ops)
(provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [mb #%module-begin])
p id strong em attr-list h1 h2 h3 h4 h5 h6
ol li ul rsquo lsquo rdquo ldquo hellip ndash mdash
hr
code pre a blockquote)
(define rsquo "")
(define rdquo "")
(define lsquo "")
(define ldquo "")
(define hellip "")
(define ndash "")
(define mdash "")
(define-tag-function (p attrs exprs)
(qexpr attrs exprs))
(define-tag-function (hr attrs exprs)
hrbr)
(define-tag-function (blockquote attrs exprs)
(qexpr (list* '(container "bq")
'(font "fira") '(fontsize "10") '(line-height "13.5")
'(inset-top "1") '(inset-bottom "7") '(inset-left "8")
attrs) exprs))
(define id (default-tag-function 'id))
(define class (default-tag-function 'class))
(define-tag-function (strong attrs exprs)
(qexpr (cons '(font "charter-bold") attrs) exprs))
(define-tag-function (a attrs exprs)
(qexpr `((link ,(cadr (assoc 'href attrs)))(color "MediumVioletRed")) exprs))
(define-tag-function (em attrs exprs)
(qexpr (cons '(font "charter-italic") attrs) exprs))
(define-syntax-rule (attr-list . attrs) 'attrs)
(define (heading-base font-size attrs exprs)
(qexpr (append `((font "fira-light")(fontsize ,(number->string font-size))(line-height ,(number->string (* 1.2 font-size)))) attrs) exprs))
(define-tag-function (h1 attrs exprs) (heading-base 20 attrs exprs))
(define-tag-function (h2 attrs exprs) (heading-base 16 attrs exprs))
(define-tag-function (h3 attrs exprs) (heading-base 14 attrs exprs))
(define h4 h3)
(define h5 h3)
(define h6 h3)
(define-tag-function (code attrs exprs)
(qexpr (append '((font "fira-mono")(fontsize "10")(bg "aliceblue")) attrs) exprs))
(define-tag-function (pre attrs exprs)
;; pre needs to convert white space to equivalent layout elements
(define new-exprs (add-between
(for*/list ([expr (in-list exprs)]
[str (in-list (string-split (string-join (get-elements expr) "") "\n"))])
`(,(get-tag expr) ,(get-attrs expr) ,str))
lbr))
(qexpr (list* '(container "codeblock") '(line-height "13") '(inset-left "12") '(inset-right "12") attrs) new-exprs))
(define (list-base attrs exprs [bullet-val #f])
(qexpr (list* '(inset-left "20") attrs)
(add-between
(for/list ([(expr idx) (in-indexed exprs)])
(list* (get-tag expr) (cons (list 'list-index (or bullet-val (format "~a." (add1 idx)))) (get-attrs expr)) (get-elements expr)))
pbr)))
(define-tag-function (ol attrs exprs) (list-base attrs exprs))
(define-tag-function (ul attrs exprs) (list-base attrs exprs ""))
(define-tag-function (li attrs exprs) (qexpr attrs exprs))
(define q:string (q #:in 'bi
#:out 'bo ;; align to baseline
;; printable unless single space, which is not printable at start or end
#:printable (λ (q [sig #f])
(match (quad-elems q)
[(cons elem _)
(case elem
[(" " #\space) (not (memq sig '(start end)))]
[else #true])]
[_ #true]))
;; draw with pdf text routine
#:draw (λ (q doc)
(when (pair? (quad-elems q))
(font doc (path->string (hash-ref (quad-attrs q) 'font)))
(font-size doc (hash-ref (quad-attrs q) 'fontsize 12))
(fill-color doc (hash-ref (quad-attrs q) 'color "black"))
(define str (unsafe-car (quad-elems q)))
(match-define (list x y) (quad-origin q))
(text doc str x y
#:bg (hash-ref (quad-attrs q) 'bg #f)
#:features (list (cons #"tnum" 1))
#:link (hash-ref (quad-attrs q) 'link #f))))
#:draw-end (λ (q doc) (draw-debug q doc "#99f" "#ccf"))))
(define-runtime-path charter "fonts/charter.ttf")
(define-runtime-path charter-bold "fonts/charter-bold.ttf")
(define-runtime-path charter-italic "fonts/charter-italic.ttf")
(define-runtime-path fira "fonts/fira.ttf")
(define-runtime-path fira-light "fonts/fira-light.ttf")
(define-runtime-path fira-mono "fonts/fira-mono.ttf")
(define default-font-face charter)
(define default-font-size 12)
(define (->string-quad doc q)
(cond
[(line-break? q) q]
[else
(struct-copy
quad q:string
[attrs (let ([attrs (quad-attrs q)])
;; attrs hashes are shared between many quads.
;; so the first update will change every reference to the shared hash
;; hence why we ignore if val is already a path
;; but this op should ideally happen earlier
(hash-update! attrs 'font
(λ (val) (if (path? val)
val
(match (string-downcase (string-replace val " " "-"))
["charter" charter]
["charter-bold" charter-bold]
["charter-italic" charter-italic]
["fira" fira]
["fira-light" fira-light]
["fira-mono" fira-mono])))
default-font-face)
(hash-ref! attrs 'fontsize default-font-size)
attrs)]
[elems (quad-elems q)]
[size (delay
(define fontsize (hash-ref (quad-attrs q) 'fontsize))
(font-size doc fontsize)
(font doc (path->string (hash-ref (quad-attrs q) 'font)))
(define str (if (pair? (quad-elems q)) (unsafe-car (quad-elems q)) ""))
(define line-height (cond
[(and (pair? (quad-elems q)) (quad-ref q 'line-height))]
[else (current-line-height doc)]))
(pt (string-width doc str) line-height))])]))
(define draw-debug? #t)
(define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"])
(when draw-debug?
(save doc)
(line-width doc 0.5)
(apply rect doc (append (quad-origin q) (size q)))
(stroke doc stroke-color)
(circle doc (pt-x (in-point q)) (pt-y (in-point q)) 2)
(circle doc (pt-x (out-point q)) (pt-y (out-point q)) 2)
(fill doc fill-color)
(rect-centered doc (pt-x (inner-point q)) (pt-y (inner-point q)) 2)
(fill doc stroke-color)
(restore doc)))
(define line-height 20)
(define dumb-hardcoded-value 380.1234)
(define q:line (q #:size (pt dumb-hardcoded-value line-height)
#:in 'nw
#:inner 'sw
#:out 'sw
#:printable #true
#:draw-start draw-debug))
(struct line-spacer quad () #:transparent)
(define q:line-spacer (q #:type line-spacer
#:size (pt dumb-hardcoded-value (* line-height 0.6))
#:out 'sw
#:printable (λ (q sig) (not (memq sig '(start end))))
#:draw-start draw-debug))
(define softies (map string '(#\space #\- #\u00AD)))
(define (soft-break-for-line? q)
(and (pair? (quad-elems q))
(member (unsafe-car (quad-elems q)) softies)))
(define (consolidate-runs pcs)
(for/fold ([runs empty]
[pcs pcs]
#:result (reverse runs))
([i (in-naturals)]
#:break (empty? pcs))
(define-values (run-pcs rest) (splitf-at pcs (λ (p) (same-run? (car pcs) p))))
(define new-run (struct-copy quad q:string
[attrs (quad-attrs (car pcs))]
[elems (merge-adjacent-strings (apply append (for/list ([pc (in-list run-pcs)])
(quad-elems pc))))]
[size (delay (pt (for/sum ([pc (in-list run-pcs)])
(pt-x (size pc)))
(pt-y (size (car pcs)))))]))
(values (cons new-run runs) rest)))
(define-quad line-break quad ())
(define lbr (make-line-break #:printable #f))
;; treat paragraph break as special kind of line break
(define-quad para-break line-break ())
(define pbr (make-para-break #:printable #f))
(define-quad hr-break para-break ())
(define hrbr (make-hr-break #:printable #t))
(module+ test
(check-true (line-break? (second (quad-elems (q "foo" pbr "bar")))))
(check-true (line-break? (second (atomize (q "foo" pbr "bar"))))))
(define (copy-block-attrs source-hash dest-hash)
(define block-attrs '(container inset-top inset-bottom))
(for ([k (in-list block-attrs)])
(cond
[(hash-ref source-hash k #f) => (λ (val) (hash-set! dest-hash k val))]))
dest-hash)
(define (line-wrap xs wrap-size)
(wrap xs (λ (q idx) (- wrap-size
(quad-ref q 'inset-left 0)
(quad-ref q 'inset-right 0)))
#:hard-break line-break?
#:soft-break soft-break-for-line?
#:finish-wrap
(λ (pcs q idx)
(append
(cond
[(empty? pcs) null]
[(hr-break? q)
(list (struct-copy quad q:line
[draw-start (λ (dq doc)
(match-define (list left top) (quad-origin dq))
(match-define (list right bottom)(size dq))
(translate doc left (+ top (/ bottom 2)))
(move-to doc 0 0)
(line-to doc right 0)
(line-width doc 3)
(stroke doc "#999"))]))]
[else
(match (consolidate-runs pcs)
[(? pair? elems)
(define elem (unsafe-car elems))
(list (struct-copy quad q:line
[attrs (copy-block-attrs (quad-attrs elem)
(hash-copy (quad-attrs q:line)))]
[size (let ()
(define line-heights
(filter-map
(λ (q) (quad-ref q 'line-height))
pcs))
(match-define (list w h) (quad-size q:line))
(pt w (if (empty? line-heights) h (apply max line-heights))))]
[elems elems]
[offset (pt
(quad-ref elem 'inset-left 0)
(second (quad-offset q:line)))]
[draw-end (match (and (or (para-break? q) (not q))
(quad-ref elem 'list-index))
[#false void]
[val (λ (q doc)
(save doc)
(match-define (list x y)
(quad-origin (car (quad-elems q))))
(text doc val x y)
(restore doc))])]))]
[_ null])])
(if (and (para-break? q) (not (hr-break? q)))
(list q:line-spacer)
null)))))
(define top-margin 60)
(define bottom-margin 120)
(define side-margin 120)
(define page-offset (pt (/ side-margin 4) (/ top-margin 3)))
(require racket/date)
(define q:page (q #:offset page-offset
#:draw-start (λ (q doc) (add-page doc)
(scale doc 3 3))
#:draw-end (λ (q doc)
(font-size doc 10)
(font doc charter)
(fill-color doc "black")
(text doc (format "~a · ~a at ~a" (hash-ref (quad-attrs q) 'page-number)
(hash-ref (quad-attrs q) 'doc-title)
(date->string (current-date) #t))
side-margin
(+ (- (pdf-height doc) bottom-margin) 20)))))
(define q:doc (q #:draw-start (λ (q doc) (start-doc doc))
#:draw-end (λ (q doc) (end-doc doc))))
(define (make-blockquote lines)
(define first-line (car lines))
(q #:attrs (hasheq 'type "bq")
#:in 'nw
#:out 'sw
#:offset (pt 0 (quad-ref first-line 'inset-top 0))
#:elems lines
#:size (delay (pt (pt-x (size first-line)) ;
(+ (for/sum ([line (in-list lines)])
(pt-y (size line)))
(quad-ref first-line 'inset-top 0)
(quad-ref first-line 'inset-bottom 0))))
#:draw-start (λ (q doc)
(match-define (list left top) (quad-origin q))
(match-define (list right bottom) (size q))
#;(rect doc (- left 4) (+ top 6) right (+ bottom 2))
(rect doc left top right bottom)
(line-width doc 1)
(fill-and-stroke doc "#eee" "#999"))))
(define (make-codeblock pcs)
(q #:attrs (hasheq 'type "codeblock")
#:in 'nw
#:out 'sw
#:elems pcs
#:size (delay (pt (pt-x (size (car pcs)))
(for/sum ([pc (in-list pcs)])
(pt-y (size pc)))))
#:draw-start (λ (q doc)
(save doc)
(match-define (list left top) (quad-origin q))
(match-define (list right bottom) (size q))
(translate doc (- left 4) (+ top 6)) ; reset origin to top left of quad
(rect doc 0 0 right (+ bottom 2))
(fill doc "aliceblue")
(define vert-line-width 6)
(move-to doc (/ vert-line-width 2) 0) ; affirmatively move cursor
(line-to doc (/ vert-line-width 2) bottom) ; strictly vert line
(line-width doc vert-line-width)
(stroke doc "#669")
#;(move-to doc 0 0) ; affirmatively move cursor
#;(line-to doc 0 bottom) ; strictly horiz line
#;(stroke doc "gray")
#;(translate doc 0 (+ bottom 2)) ; reset origin
#;(move-to doc 0 0) ; move again
#;(line-to doc right 0) ; same line, translated
(stroke doc "gray")
(restore doc))))
(define (contiguous-group-by pred xs)
;; like `group-by`, but only groups together contiguous xs with the same pred value.
(let loop ([xs xs][groups null])
(match xs
[(== empty) (reverse groups)]
[(cons first-x other-xs)
(define equivalence-val (pred first-x))
(define-values (group-members rest) (splitf-at other-xs (λ (x) (equal? (pred x) equivalence-val))))
(define new-group (cons first-x group-members)) ; group-members might be empty
(loop rest (cons new-group groups))])))
(module+ test
(require rackunit)
(check-equal?
(contiguous-group-by values '(1 1 2 2 2 3 4 5 5 6 6 7 8 9))
'((1 1) (2 2 2) (3) (4) (5 5) (6 6) (7) (8) (9))))
(define (page-wrap xs vertical-height path)
(wrap xs vertical-height
#:soft-break line-spacer?
#:wrap-anywhere? #t
#:finish-wrap (λ (lns q idx)
(list (struct-copy quad q:page
[attrs (let ([page-number idx]
[h (hash-copy (quad-attrs q:page))])
(hash-set! h 'page-number page-number)
(define-values (dir name _)
(split-path (path-replace-extension path #"")))
(hash-set! h 'doc-title (string-titlecase (path->string name)))
h)]
[elems lns])))))
(define (insert-containers pages)
;; container recomposition happens after page composition because page breaks can happen between lines.
;; iow, the lines within a container may be split over multiple pages, each of which should be drawn
;; as a separate container
(for/list ([page (in-list pages)])
(define lns (quad-elems page))
(define groups (contiguous-group-by (λ (x) (hash-ref (quad-attrs x) 'container #f)) lns))
(define lns-and-containers (append* (for/list ([grp (in-list groups)])
(match (hash-ref (quad-attrs (car grp)) 'container #f)
["bq" (list (make-blockquote grp))]
["codeblock" (list (make-codeblock grp))]
[_ grp]))))
(struct-copy quad page [elems lns-and-containers])))
(define (run xs path)
(define pdf (time-name make-pdf (make-pdf #:compress #t
#:auto-first-page #f
#:output-path path
#:width 350
#:height 400)))
(define line-width (- (pdf-width pdf) (* 2 side-margin)))
(define vertical-height (- (pdf-height pdf) top-margin bottom-margin))
(let* ([x (time-name atomize (atomize (qexpr->quad xs)))]
[x (time-name ->string-quad (map (λ (x) (->string-quad pdf x)) x))]
[x (time-name line-wrap (line-wrap x line-width))]
[x (time-name page-wrap (page-wrap x vertical-height path))]
[x (time-name insert-containers (insert-containers x))]
[x (time-name position (position (struct-copy quad q:doc [elems x])))])
(time-name draw (draw x pdf))))
(define-syntax (mb stx)
(syntax-case stx ()
[(_ PDF-PATH . STRS)
#'(#%module-begin
;; stick an nbsp in the strings so we have one printing char
(define strs (match (list . STRS)
[(? null?) '(" ")]
[strs strs]))
(define qx (list* 'q null (add-between strs pbr)))
(run qx PDF-PATH))]))
(module+ reader
(require scribble/reader syntax/strip-context (only-in markdown parse-markdown)
racket/match txexpr)
(provide (rename-out [quad-read-syntax read-syntax]))
(define (xexpr->parse-tree x)
;; an ordinary txexpr can't serve as a parse tree because of the attrs list fails when passed to #%app.
;; so stick an `attr-list` identifier on it which can hook into the expander.
;; sort of SXML-ish.
(let loop ([x x])
(match x
[(txexpr tag attrs elems) (list* tag (cons 'attr-list attrs) (map loop elems))]
[(? list? xs) (map loop xs)]
[_ x])))
(define (quad-read-syntax path-string p)
(define quad-at-reader (make-at-reader
#:syntax? #t
#:inside? #t
#:command-char #\◊))
(define stx (quad-at-reader path-string p))
(define parsed-stx (datum->syntax stx (xexpr->parse-tree (parse-markdown (apply string-append (syntax->datum stx))))))
(strip-context
(with-syntax ([PT parsed-stx]
[PDF-PATH (path-replace-extension path-string #".pdf")])
#'(module _ qtest/markdown
PDF-PATH
. PT)))))