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

579 lines
28 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/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)
;; no font-family so that it adopts whatever the surrounding family is
(qexpr (append `((keep-first "2")(keep-last "3") (display ,(symbol->string (gensym)))) attrs) exprs))
(define-tag-function (hr attrs exprs)
hrbr)
(define-tag-function (blockquote attrs exprs)
(qexpr (append '((display "block")
(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 "120%") 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 "90%") 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")(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? #f)
(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 (hash-ref (quad-attrs q) font-path-key)))
(font-size doc (hash-ref (quad-attrs q) 'font-size 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 (if draw-debug-string?
(λ (q doc) (draw-debug q doc "#99f" "#ccf"))
void)))
(define default-font-face "fonts/default.ttf")
(define default-font-family "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)])
(hash-ref! attrs 'font-size default-font-size)
attrs)]
[elems (quad-elems q)]
[size (delay
(font-size doc (quad-ref q 'font-size))
(font doc (path->string (quad-ref q font-path-key)))
(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 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)
#: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)
(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 '(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))
(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 (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?
;; 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 opening-q ending-q idx)
(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)
[(? pair? elems)
(define elem (unsafe-car elems))
(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 (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))))]
;; handle list indexes. drop new quad into line to hold list index
;; could also use this for line numbers
[elems (append
(match (and (= 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 (= 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) (map + (quad-origin q) (list bil bit)))
(match-define (list width height) (map - (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 (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)
(let* ([x (time-name parse-qexpr (qexpr->quad xs))]
[x (time-name atomize (atomize x #:attrs-proc handle-cascading-attrs))]
[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 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)))))