typesetting/quad/qtest/markdown.rkt

#lang debug racket/base
(require (for-syntax racket/base) txexpr racket/runtime-path racket/path racket/string racket/promise racket/match racket/list
         pitfall quad sugar/debug pollen/tag racket/unsafe/ops hyphenate)
(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)
  ;; no font-family so that it adopts whatever the surrounding family is
  (qexpr (append `((keep-first "2")(keep-last "3")(line-align "justify")(font-size "12") (character-tracking "0") (hyphenate "true") (display ,(symbol->string (gensym)))) attrs) exprs))

(define-tag-function (hr attrs exprs)
  hrbr)

(define-tag-function (blockquote attrs exprs)
  (qexpr (append '((display "block")
                   (line-align "right")
                   (background-color "#eee")
                   (font-family "fira") (font-size "10") (line-height "15")
                   (border-width-top "0.5") (border-color-top "gray") (border-inset-top "8")
                   (border-width-left "3") (border-color-left "gray") (border-inset-left "20")
                   (border-width-bottom "0.5") (border-color-bottom "gray") (border-inset-bottom "-2")
                   (border-width-right "0.5") (border-color-right "gray") (border-inset-right "20")
                   (inset-top "10") (inset-bottom "8") (inset-left "30") (inset-right "30")
                   (keep-lines "yes"))
                 attrs) exprs))

(define id (default-tag-function 'id))
(define class (default-tag-function 'class))

(define-tag-function (strong attrs exprs)
  (qexpr (list* '(font-bold "true") '(font-size-adjust "100%") attrs) exprs))

(define-tag-function (a attrs exprs)
  (qexpr `((link ,(cadr (assoc 'href attrs)))(color "MediumVioletRed")) exprs))

(define-tag-function (em attrs exprs)
  (qexpr (list* '(font-italic "true") '(font-size-adjust "100%") attrs) exprs))

(define-syntax-rule (attr-list . attrs) 'attrs)

(define (heading-base font-size attrs exprs)
  (qexpr (append `((font-family "fira-light") (display "block") (font-size ,(number->string font-size))(line-height ,(number->string (* 1.2 font-size))) (border-width-top "0.5")(border-inset-top "9")(border-inset-right "12") (inset-bottom "-3") (inset-top "6") (keep-with-next "true")) attrs) exprs))

(define-tag-function (h1 attrs exprs)
  (heading-base 20 (append '() 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-family "fira-mono")#;(line-align "right")(font-size "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) ,(string-replace str " " " ")))
                     lbr))
  (qexpr (list* '(display "block") '(background-color "aliceblue")
                '(font-family "fira-mono") '(font-size "11") '(line-height "14")
                '(border-inset-top "10")
                '(border-width-left "2") '(border-color-left "#669") '(border-inset-left "0")
                '(border-inset-right "10") '(border-inset-bottom "-4")
                '(inset-left "12") '(inset-right "12")  '(inset-top "12") '(inset-bottom "8")
                attrs) new-exprs))


(define draw-debug? #t)
(define draw-debug-line? #t)
(define draw-debug-block? #t)
(define draw-debug-string? #f)


(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 (quad-ref q font-path-key)))
                               (font-size doc (quad-ref q 'font-size 12))
                               (fill-color doc (quad-ref q 'color "black"))
                               (define str (unsafe-car (quad-elems q)))
                               (match-define (list x y) (quad-origin q))
                               (text doc str x y
                                     #:tracking (quad-ref q 'character-tracking 0)
                                     #:bg (quad-ref q 'bg #f)
                                     #:features (list (cons #"tnum" 1))
                                     #:link (quad-ref q 'link #f))))
                    #:draw-end (if draw-debug-string?
                                   (λ (q doc) (draw-debug q doc "#99f" "#ccf"))
                                   void)))

(define-runtime-path default-font-face "fonts/charter/charter.otf")
(define default-font-family "charter")
(define default-font-size 12)

(define current-doc (make-parameter #f))

(define (make-size-promise q [str-arg #f])
  (delay
    (define doc (current-doc))
    (define str
      (cond
        [str-arg]
        [(pair? (quad-elems q)) (unsafe-car (quad-elems q))]
        [else #false]))
    (define string-size
      (cond
        [str
         (font-size doc (quad-ref q 'font-size default-font-size))
         (font doc (path->string (quad-ref q font-path-key default-font-face)))
         (+ (string-width doc str
                          #:tracking (quad-ref q 'character-tracking 0))
            ;; add one more dose because `string-width` only adds it intercharacter,
            ;; and this quad will be adjacent to another
            ;; (so we need to account for the "inter-quad" space
            (quad-ref q 'character-tracking 0))]
        [else 0]))
    (list string-size (quad-ref q 'line-height (current-line-height doc)))))

(define (->string-quad q)
  (cond
    [(line-break? q) q]
    [else
     (struct-copy
      quad q:string
      [attrs (let ([attrs (quad-attrs q)])
               (hash-ref! attrs 'font-size default-font-size)
               attrs)]
      [elems (quad-elems q)]
      [size (make-size-promise q)])]))


(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 372)
(define q:line (q #:size (pt dumb-hardcoded-value line-height)
                  #:inner 'sw
                  #:out 'sw
                  #:printable #true
                  #:draw-start (if draw-debug-line? draw-debug void)))
(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 (if draw-debug-line? draw-debug void)))
(define q:line-spacer-unbreakable
  (struct-copy line-spacer q:line-spacer
               [attrs #:parent quad
                      (make-hasheq '((keep-lines . #true)))]))

(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 ending-q)
  (define reversed-runs
    (for/fold ([runs empty]
               [pcs pcs]
               #:result 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)))
  ;; naive handling of soft hyphen:
  ;; if soft hyphen cause the break, then append a printing hyphen to the end of the run.
  ;; this assumes that there is room for the hyphen on the line
  ;; and does not take into account hyphen-break transformations found in other languages.
  ;; However we do want the hyphen joined into the string so the final shaping / positioning is correct
  ;; for instance, kerning between last letter and hyphen.
  (reverse (if (and ending-q (equal? (quad-elems ending-q) '("\u00AD")))
               (cons (let* ([last-run (car reversed-runs)]
                            [str+hyphen (string-append (car (quad-elems last-run)) "-")])
                       (struct-copy quad last-run
                                    [elems (list str+hyphen)]
                                    [size (make-size-promise last-run str+hyphen)])) (cdr reversed-runs))
               reversed-runs)))

(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 '(display
                        inset-top inset-bottom inset-left inset-right
                        border-inset-top  border-inset-bottom border-inset-left border-inset-right
                        border-width-left border-width-right border-width-top border-width-bottom
                        border-color-left border-color-right border-color-top border-color-bottom
                        background-color
                        keep-lines keep-first keep-last keep-all keep-with-next
                        line-align line-align-first line-align-last))
  (for* ([k (in-list block-attrs)]
         [v (in-value (hash-ref source-hash k #f))]
         #:when v)
    (hash-set! dest-hash k v))
  dest-hash)

(define (handle-hyphenate qs)
  ;; find quads that want hyphenation and split them into smaller pieces
  ;; do this before ->string-quad so that it can handle the sizing promises
  (apply append (for/list ([q (in-list qs)])
                  (match (quad-ref q 'hyphenate #false)
                    [(or #false "false") (list q)]
                    [_ (for*/list ([str (in-list (quad-elems q))]
                                   [hyphen-char (in-value #\u00AD)]
                                   [hstr (in-value (hyphenate str hyphen-char
                                                              #:min-left-length 4
                                                              #:min-right-length 3))]
                                   [substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))])
                         (struct-copy quad q [elems (list substr)]))]))))

(require sugar/list)
(define (fill-wrap qs ending-q)
  (match-define (list line-width line-height) (quad-size q:line))
  ;; todo: how to detect last line of paragraph?
  (match (and ending-q (pair? qs) (quad-ref (car qs) 'line-align #f))
    ["justify"
     ;; words may still be in hyphenated fragments
     ;; (though soft hyphens would have been removed)
     (define word-sublists (filter-split qs (λ (q) (equal? (car (quad-elems q)) " "))))
     (match (length word-sublists)
       [1 qs] ; can't justify single word
       [word-count
        (define words-width (for*/sum ([word-sublist (in-list word-sublists)]
                                       [word (in-list word-sublist)])
                              (pt-x (size word))))
        (define empty-hspace (- line-width
                                (quad-ref (car qs) 'inset-left 0)
                                words-width
                                (quad-ref (car qs) 'inset-right 0)))
        (define space-width (/ empty-hspace (sub1 word-count)))
        (apply append (add-between word-sublists (list (make-quad #:size (pt space-width line-height)))))])]
    [_ qs]))

(define (line-wrap qs wrap-size)
  (wrap qs
        (λ (q idx) (- wrap-size (quad-ref q 'inset-left 0) (quad-ref q 'inset-right 0)))
        #:nicely #t
        #:hard-break line-break?
        #:soft-break soft-break-for-line?
        ;; restart wrap count after each paragraph break
        ;; so idx=1 means first line in any paragraph
        #:wrap-count (λ (idx q) (if (para-break? q) 1 (add1 idx)))
        #:finish-wrap
        (λ (pcs-in opening-q ending-q idx)
          ;; remove unused soft hyphens so they don't affect final shaping
          (define pcs-printing (for/list ([pc (in-list pcs-in)]
                                          #:unless (equal? (quad-elems pc) '("\u00AD")))
                                 pc))
          (define pcs (fill-wrap pcs-printing ending-q))
          (append
           (cond
             [(empty? pcs) null]
             [(hr-break? ending-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 ending-q)
                [(? pair? elems)
                 (define elem (unsafe-car elems))
                 (match-define (list line-width line-height) (quad-size q:line))
                 (define new-size (let ()
                                    (define line-heights
                                      (filter-map (λ (q) (quad-ref q 'line-height)) pcs))
                                    (pt line-width (if (empty? line-heights) line-height (apply max line-heights)))))
                 (list (struct-copy quad q:line
                                    ;; move block attrs up, so they are visible in page wrap
                                    [attrs (copy-block-attrs (quad-attrs elem)
                                                             (hash-copy (quad-attrs q:line)))]
                                    ;; line width is static
                                    ;; line height is the max 'line-height value or the natural height of q:line
                                    [size new-size]
                                    [offset (let ()
                                              (define elems-width (pt-x (apply pt+ (map size elems))))
                                              (define h-factor (match (quad-ref elem 'line-align "left")
                                                                 ["left" 0]
                                                                 ["center" 0.5]
                                                                 ["right" 1]
                                                                 [_ 0]))
                                              (define empty-hspace (- line-width
                                                                      (quad-ref elem 'inset-left 0)
                                                                      elems-width
                                                                      (quad-ref elem 'inset-right 0)))
                                              (pt+ (quad-offset q:line) (pt (* empty-hspace h-factor) 0)))]
                                    ;; handle list indexes. drop new quad into line to hold list index
                                    ;; could also use this for line numbers
                                    [elems (append
                                            (match (and (eq? idx 1) (quad-ref elem 'list-index))
                                              [#false null]
                                              [bullet (list (make-quad
                                                             #:elems (list (struct-copy quad (car elems)
                                                                                        [elems (list (if (number? bullet)
                                                                                                         (format "~a." bullet)
                                                                                                         bullet))]))))])
                                            (list (make-quad
                                                   #:offset (pt (quad-ref elem 'inset-left 0) 0)
                                                   #:elems elems)))]))]
                [_ null])])
           (if (and (para-break? ending-q) (not (hr-break? ending-q)))
               (list q:line-spacer)
               null)))))

(define (make-nobreak! q) (quad-set! q 'no-pbr "true"))

(define (do-keep-with-next! reversed-lines)
  ;; paints nobreak onto spacers that follow keep-with-next lines
  ;; (we are iterating backward, so the geometrically previous ln follows the spacer)
  (for ([this-ln (in-list reversed-lines)]
        [prev-ln (in-list (cdr reversed-lines))]
        #:when (and (line-spacer? this-ln)
                    (quad-ref prev-ln 'keep-with-next)))
    (make-nobreak! prev-ln)
    (make-nobreak! this-ln)))

(define (apply-keeps lines)
  (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x 'display)) lines))
  (for*/fold ([reversed-lines null]
              #:result (begin
                         (do-keep-with-next! reversed-lines)
                         (reverse reversed-lines)))
             ([group (in-list groups-of-lines)]
              [group-len (in-value (length group))]
              [(ln idx0) (in-indexed group)])
    (define idx (add1 idx0))
    ;; always catch last line of block in this case
    ;; so later cases are guaranteed to have earlier lines.
    (unless (eq? idx group-len)
      (cond
        ;; if we have 'keep-all we can skip 'keep-first and 'keep-last cases
        [(quad-ref ln 'keep-all) (make-nobreak! ln)]
        ;; to keep n lines, we only paint the first n - 1
        ;; (because each nobr line sticks to the next)
        [(let ([keep-first (quad-ref ln 'keep-first)])
           (and (number? keep-first) (< idx keep-first)))
         (make-nobreak! ln)]
        [(let ([keep-last (quad-ref ln 'keep-last)])
           (and (number? keep-last) (< (- group-len keep-last) idx)))
         (make-nobreak! ln)]))
    (cons ln reversed-lines)))

(define zoom-mode? #f)
(define zoom-scale 2)
(define top-margin (/ 60 (if zoom-mode? zoom-scale 1)))
(define bottom-margin (/ 120 (if zoom-mode? zoom-scale 1)))
(define side-margin (/ 120 (if zoom-mode? zoom-scale 1)))
(define page-offset (pt (/ side-margin (if zoom-mode? 3 1))
                        (/ top-margin (if zoom-mode? 3 1))))
(require racket/date)
(define q:page (q #:offset page-offset
                  #:draw-start (λ (q doc) (add-page doc)
                                 (scale doc (if zoom-mode? zoom-scale 1) (if zoom-mode? zoom-scale 1)))
                  #:draw-end (λ (q doc)
                               (font-size doc 10)
                               (font doc default-font-face)
                               (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 (block-wrap lines)
  (define first-line (car lines)) 
  (q #: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)
                    ;; adjust drawing coordinates for border inset
                    (match-define (list bil bit bir bib)
                      (map (λ (k) (quad-ref first-line k 0))
                           '(border-inset-left border-inset-top border-inset-right border-inset-bottom)))
                    (match-define (list left top) (pt+ (quad-origin q) (list bil bit)))
                    (match-define (list width height) (pt- (size q) (list (+ bil bir) (+ bit bib))))
                    ;; fill rect
                    (cond 
                      [(quad-ref first-line 'background-color)
                       => (λ (bgcolor)
                            (rect doc left top width height)
                            (fill doc bgcolor))])
                    ;; draw border
                    (match-define (list bw-left bw-top bw-right bw-bottom)
                      (map (λ (k) (max 0 (quad-ref first-line k 0))) '(border-width-left
                                                                       border-width-top
                                                                       border-width-right
                                                                       border-width-bottom)))
                    ;; adjust start and end points based on adjacent border width
                    ;; so all borders overlap rectangularly
                    (define (half x) (/ x 2.0))
                    (define right (+ left width))
                    (define bottom (+ top height))
                    (define (box-side x1 y1 x2 y2 color stroke-width)
                      (when (positive? stroke-width)
                        (move-to doc x1 y1)
                        (line-to doc x2 y2)
                        (stroke doc (or color "black") stroke-width)))
                    (box-side (- left (half bw-left)) top (+ right (half bw-right)) top
                              (quad-ref first-line 'border-color-top) bw-top)
                    (box-side right (- top (half bw-top)) right (+ bottom (half bw-bottom))
                              (quad-ref first-line 'border-color-right) bw-right)
                    (box-side (+ right (half bw-right)) bottom (- left (half bw-left)) bottom
                              (quad-ref first-line 'border-color-bottom) bw-bottom)
                    (box-side left (+ bottom (half bw-bottom)) left (- top (half bw-top))
                              (quad-ref first-line 'border-color-left) bw-left))
     #:draw-end (if draw-debug-block?
                    (λ (q doc) (draw-debug q doc "#6c6" "#9c9"))
                    void))) 


(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)
  ;; on timing of `insert-blocks`:
  ;; can't do it before because it depends on where pages are broken.
  ;; could do it after, but it would require going back inside each page quad
  ;; which seems overly interdependent, because `insert-blocks` is used to determine break locations.
  ;; `page-wrap` should emit quads that are complete.
  (wrap xs vertical-height
        #:soft-break (λ (q) #true)
        #:no-break (λ (q) (quad-ref q 'no-pbr))
        #:distance (λ (q dist-so-far wrap-qs)
                     ;; do trial block insertions
                     (for/sum ([x (in-list (insert-blocks wrap-qs))])
                       (pt-y (size x))))                     
        #:finish-wrap (λ (lns q0 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 (insert-blocks lns)])))))

(define (insert-blocks lines)
  (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x 'display)) lines))
  (append* (for/list ([line-group (in-list groups-of-lines)])
             (match (quad-ref (car line-group) 'display)
               [#false line-group]
               [_ (list (block-wrap line-group))]))))

(define font-paths (make-hash))

(define (setup-font-path-table! base-path)
  ;; populate `font-paths` table with font paths
  ;; search "fonts" subdirectory in project for other subdirectories
  ;; which are presumed to contain fonts.
  ;; and link them to their family names & styles.
  ;; this allows a flexible mapping from internal to external names, like @font-face
  ;; note that all the semantics are derived from the file system
  ;; not any metadata fields within the font.
  ;; this is faster and easier, because you can just muck with the directory and filenames
  ;; to change the font mapping.
  ;; though it also creates the potential for mischief,
  ;; if a font is named something that doesn't reflect its visual reality.
  ;; but we are not the font police.
  (define-values (dir path _) (split-path base-path))
  (define fonts-dir (build-path dir "fonts"))
  (for* ([font-family-subdir (in-directory fonts-dir)]
         #:when (directory-exists? font-family-subdir)
         [font-path (in-directory font-family-subdir)]
         #:when (or (path-has-extension? font-path #"otf")
                    (path-has-extension? font-path #"ttf")))
    (match-define (list font-path-string family-name)
      (map (λ (x) (path->string (find-relative-path fonts-dir x))) (list font-path font-family-subdir)))
    (define key
      (cons family-name
            (match (string-downcase font-path-string)
              [(and (regexp "bold") (regexp "italic")) 'bi]
              [(regexp "bold") 'b]
              [(regexp "italic") 'i]
              [_ 'r])))
    ;; only set value if there's not one there already.
    ;; this means that we only use the first eligible font we find.
    (hash-ref! font-paths key font-path)))

(define (font-attrs->path font-family bold italic)
  ;; find the font-path corresponding to a certain family name and style.
  (define key (cons font-family
                    (cond
                      [(and bold italic) 'bi]
                      [bold 'b]
                      [italic 'i]
                      [else 'r])))
  (define regular-key (cons font-family 'r))
  (cond
    [(hash-ref font-paths key #false)]
    ;; if there isn't one, try the regular style.
    [(hash-ref font-paths regular-key #false)]
    ;; If there isn't one, use the default.
    [else default-font-face]))

(define (resolve-font-path attrs)
  (define this-font-family (hash-ref! attrs 'font-family default-font-family))
  (define this-bold (hash-ref! attrs 'font-bold #false))
  (define this-italic (hash-ref! attrs 'font-italic #false))
  (hash-set! attrs 'font-path (font-attrs->path this-font-family this-bold this-italic)))

(define (parse-percentage pstr)
  (/ (string->number (string-trim pstr "%")) 100.0))

(define (resolve-font-size attrs)
  (define this-font-size (hash-ref! attrs 'font-size default-font-size))
  (define this-font-size-adjust (parse-percentage (hash-ref! attrs 'font-size-adjust "100%")))
  ;; we bake the adjustment into the font size...
  (hash-set! attrs 'font-size (* this-font-size this-font-size-adjust))
  ;; and then set the adjustment back to 100% (since it's now accounted for)
  (hash-set! attrs 'font-size-adjust "100%"))

(define (handle-cascading-attrs attrs)
  (resolve-font-path attrs)
  (resolve-font-size attrs))
                 
(define (run xs pdf-path)
  (define pdf (time-name make-pdf (make-pdf #:compress #t
                                            #:auto-first-page #f
                                            #:output-path pdf-path
                                            #:width (if zoom-mode? 350 612)
                                            #:height (if zoom-mode? 400 792))))
  (define line-width (- (pdf-width pdf) (* 2 side-margin)))
  (define vertical-height (- (pdf-height pdf) top-margin bottom-margin))
  (setup-font-path-table! pdf-path)
  (parameterize ([current-doc pdf])
    (let* ([x (time-name parse-qexpr (qexpr->quad xs))]
           [x (time-name atomize (atomize x #:attrs-proc handle-cascading-attrs))]
           [x (time-name hyphenate (handle-hyphenate x))]
           [x (time-name ->string-quad (map ->string-quad x))]
           [x (time-name line-wrap (line-wrap x line-width))]
           [x (time-name apply-keeps (apply-keeps x))]
           [x (time-name page-wrap (page-wrap x vertical-height pdf-path))]
           [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)))))