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

522 lines
25 KiB
Racket

6 years ago
#lang debug racket/base
6 years ago
(require (for-syntax racket/base) txexpr racket/runtime-path racket/string racket/promise racket/match racket/list
6 years ago
pitfall quad sugar/debug pollen/tag racket/unsafe/ops)
6 years ago
(provide (except-out (all-from-out racket/base) #%module-begin)
6 years ago
(rename-out [mb #%module-begin])
6 years ago
p id strong em attr-list h1 h2 h3 h4 h5 h6
6 years ago
ol li ul rsquo lsquo rdquo ldquo hellip ndash mdash
6 years ago
hr
code pre a blockquote)
(define rsquo "")
6 years ago
(define rdquo "")
6 years ago
(define lsquo "")
6 years ago
(define ldquo "")
6 years ago
(define hellip "")
6 years ago
(define ndash "")
(define mdash "")
6 years ago
6 years ago
(define-tag-function (p attrs exprs)
6 years ago
(qexpr (append `((keep-first "2")(keep-last "2")(display ,(symbol->string (gensym)))) attrs) exprs))
6 years ago
6 years ago
(define-tag-function (hr attrs exprs)
6 years ago
hrbr)
6 years ago
(define-tag-function (blockquote attrs exprs)
6 years ago
(qexpr (append '((display "block")
(background-color "#eee")
(font "fira") (fontsize "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")
6 years ago
(keep-lines "yes"))
6 years ago
attrs) exprs))
6 years ago
(define id (default-tag-function 'id))
6 years ago
(define class (default-tag-function 'class))
6 years ago
6 years ago
(define-tag-function (strong attrs exprs)
6 years ago
(qexpr (cons '(font "charter-bold") attrs) exprs))
6 years ago
6 years ago
(define-tag-function (a attrs exprs)
6 years ago
(qexpr `((link ,(cadr (assoc 'href attrs)))(color "MediumVioletRed")) exprs))
6 years ago
6 years ago
(define-tag-function (em attrs exprs)
6 years ago
(qexpr (cons '(font "charter-italic") attrs) exprs))
6 years ago
6 years ago
(define-syntax-rule (attr-list . attrs) 'attrs)
6 years ago
6 years ago
(define (heading-base font-size attrs exprs)
6 years ago
(qexpr (append `((font "fira-light") (display "block") (fontsize ,(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))
6 years ago
(define-tag-function (h1 attrs exprs)
(heading-base 20 (append '() attrs) exprs))
6 years ago
6 years ago
(define-tag-function (h2 attrs exprs) (heading-base 16 attrs exprs))
(define-tag-function (h3 attrs exprs) (heading-base 14 attrs exprs))
6 years ago
6 years ago
(define h4 h3)
(define h5 h3)
(define h6 h3)
6 years ago
(define-tag-function (code attrs exprs)
6 years ago
(qexpr (append '((font "fira-mono")(fontsize "10")(bg "aliceblue")) attrs) exprs))
6 years ago
(define-tag-function (pre attrs exprs)
6 years ago
;; pre needs to convert white space to equivalent layout elements
(define new-exprs (add-between
(for*/list ([expr (in-list exprs)]
6 years ago
[str (in-list (string-split (string-join (get-elements expr) "") "\n"))])
6 years ago
`(,(get-tag expr) ,(get-attrs expr) ,(string-replace str " " " ")))
6 years ago
lbr))
6 years ago
(qexpr (list* '(display "block") '(background-color "aliceblue")
'(font "fira-mono") '(fontsize "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")
6 years ago
'(inset-left "12") '(inset-right "12") '(inset-top "12") '(inset-bottom "8")
6 years ago
attrs) new-exprs))
6 years ago
6 years ago
(define draw-debug? #t)
6 years ago
(define draw-debug-line? #f)
6 years ago
(define draw-debug-block? #t)
6 years ago
(define draw-debug-string? #f)
6 years ago
(define (list-base attrs exprs [bullet-val #f])
(qexpr (list* '(inset-left "20") attrs)
6 years ago
(add-between
(for/list ([(expr idx) (in-indexed exprs)])
6 years ago
(list* (get-tag expr) (cons (list 'list-index (or bullet-val (format "~a" (add1 idx)))) (get-attrs expr)) (get-elements expr)))
6 years ago
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))
6 years ago
6 years ago
(define q:string (q #:in 'bi
#:out 'bo ;; align to baseline
6 years ago
;; printable unless single space, which is not printable at start or end
#:printable (λ (q [sig #f])
6 years ago
(match (quad-elems q)
[(cons elem _)
(case elem
[(" " #\space) (not (memq sig '(start end)))]
[else #true])]
[_ #true]))
6 years ago
;; draw with pdf text routine
#:draw (λ (q doc)
6 years ago
(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))
6 years ago
(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))))
6 years ago
#:draw-end (if draw-debug-string?
(λ (q doc) (draw-debug q doc "#99f" "#ccf"))
void)))
6 years ago
(define-runtime-path charter "fonts/charter.ttf")
6 years ago
(define-runtime-path charter-bold "fonts/charter-bold.ttf")
(define-runtime-path charter-italic "fonts/charter-italic.ttf")
6 years ago
(define-runtime-path fira "fonts/fira.ttf")
(define-runtime-path fira-light "fonts/fira-light.ttf")
6 years ago
(define-runtime-path fira-mono "fonts/fira-mono.ttf")
6 years ago
6 years ago
(define default-font-face charter)
(define default-font-size 12)
6 years ago
6 years ago
(define (->string-quad doc q)
6 years ago
(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]
6 years ago
["fira-light" fira-light]
6 years ago
["fira-mono" fira-mono])))
default-font-face)
(hash-ref! attrs 'fontsize default-font-size)
6 years ago
attrs)]
[elems (quad-elems q)]
[size (delay
(define fontsize (hash-ref (quad-attrs q) 'fontsize))
6 years ago
(font-size doc fontsize)
(font doc (path->string (hash-ref (quad-attrs q) 'font)))
6 years ago
(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))])]))
6 years ago
6 years ago
(define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"])
6 years ago
(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)))
6 years ago
(define line-height 20)
6 years ago
(define dumb-hardcoded-value 380.1234)
(define q:line (q #:size (pt dumb-hardcoded-value line-height)
#:inner 'sw
6 years ago
#:out 'sw
6 years ago
#:printable #true
6 years ago
#:draw-start (if draw-debug-line? draw-debug void)))
6 years ago
(struct line-spacer quad () #:transparent)
(define q:line-spacer (q #:type line-spacer
6 years ago
#:size (pt dumb-hardcoded-value (* line-height 0.6))
6 years ago
#:out 'sw
6 years ago
#:printable (λ (q sig) (not (memq sig '(start end))))
6 years ago
#:draw-start (if draw-debug-line? draw-debug void)))
6 years ago
(define q:line-spacer-unbreakable
(struct-copy line-spacer q:line-spacer
[attrs #:parent quad
6 years ago
(make-hasheq '((keep-lines . #true)))]))
6 years ago
(define softies (map string '(#\space #\- #\u00AD)))
6 years ago
6 years ago
(define (soft-break-for-line? q)
6 years ago
(and (pair? (quad-elems q))
(member (unsafe-car (quad-elems q)) softies)))
6 years ago
(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)])
6 years ago
(quad-elems pc))))]
6 years ago
[size (delay (pt (for/sum ([pc (in-list run-pcs)])
6 years ago
(pt-x (size pc)))
6 years ago
(pt-y (size (car pcs)))))]))
(values (cons new-run runs) rest)))
6 years ago
(define-quad line-break quad ())
(define lbr (make-line-break #:printable #f))
6 years ago
;; treat paragraph break as special kind of line break
6 years ago
(define-quad para-break line-break ())
(define pbr (make-para-break #:printable #f))
6 years ago
(define-quad hr-break para-break ())
(define hrbr (make-hr-break #:printable #t))
6 years ago
(module+ test
(check-true (line-break? (second (quad-elems (q "foo" pbr "bar")))))
(check-true (line-break? (second (atomize (q "foo" pbr "bar"))))))
6 years ago
(define (copy-block-attrs source-hash dest-hash)
6 years ago
(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
6 years ago
background-color
6 years ago
keep-lines keep-first keep-last keep-all keep-with-next))
6 years ago
(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)
6 years ago
(define (line-wrap xs wrap-size)
6 years ago
(wrap xs (λ (q idx) (- wrap-size
(quad-ref q 'inset-left 0)
(quad-ref q 'inset-right 0)))
6 years ago
#:hard-break line-break?
#:soft-break soft-break-for-line?
6 years ago
;; 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)))
6 years ago
#:finish-wrap
6 years ago
(λ (pcs opening-q ending-q idx)
6 years ago
(append
6 years ago
(cond
[(empty? pcs) null]
6 years ago
[(hr-break? ending-q)
6 years ago
(list (struct-copy quad q:line
[draw-start (λ (dq doc)
6 years ago
(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"))]))]
6 years ago
[else
(match (consolidate-runs pcs)
[(? pair? elems)
(define elem (unsafe-car elems))
6 years ago
(list (struct-copy quad q:line
6 years ago
;; move block attrs up, so they are visible in page wrap
[attrs (copy-block-attrs (quad-attrs elem)
(hash-copy (quad-attrs q:line)))]
6 years ago
;; line width is static
;; line height is the max 'line-height value or the natural height of q:line
6 years ago
[size (let ()
(define line-heights
6 years ago
(filter-map (λ (q) (quad-ref q 'line-height)) pcs))
6 years ago
(match-define (list w h) (quad-size q:line))
(pt w (if (empty? line-heights) h (apply max line-heights))))]
6 years ago
;; handle list indexes. drop new quad into line to hold list index
6 years ago
;; could also use this for line numbers
6 years ago
[elems (append
(match (and (= idx 1) (quad-ref elem 'list-index))
6 years ago
[#false null]
[bullet (list (make-quad
6 years ago
#:elems (list (struct-copy quad (car elems)
[elems (list (if (number? bullet)
(format "~a." bullet)
bullet))]))))])
6 years ago
(list (make-quad
#:offset (pt (quad-ref elem 'inset-left 0) 0)
6 years ago
#:elems elems)))]))]
[_ null])])
6 years ago
(if (and (para-break? ending-q) (not (hr-break? ending-q)))
6 years ago
(list q:line-spacer)
6 years ago
null)))))
6 years ago
6 years ago
(define (make-nobreak! q) (quad-set! q 'no-pbr "true"))
(define (finish-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! 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
(finish-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))
(cond
;; always catch last line of block in this case
;; so later cases are guaranteed to have earlier lines.
[(= idx group-len)
(when (quad-ref ln 'keep-with-next)
(make-nobreak! ln))]
;; 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)))
6 years ago
(define zoom-mode? #f)
(define top-margin 60)
(define bottom-margin 120)
6 years ago
(define side-margin 120)
6 years ago
(define page-offset (pt (/ side-margin (if zoom-mode? 3 1))
(/ top-margin (if zoom-mode? 3 1))))
(require racket/date)
6 years ago
(define q:page (q #:offset page-offset
#:draw-start (λ (q doc) (add-page doc)
6 years ago
(scale doc (if zoom-mode? 3 1) (if zoom-mode? 3 1)))
#:draw-end (λ (q doc)
(font-size doc 10)
6 years ago
(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)))))
6 years ago
(define q:doc (q #:draw-start (λ (q doc) (start-doc doc))
#:draw-end (λ (q doc) (end-doc doc))))
6 years ago
6 years ago
(define (block-wrap lines)
(define first-line (car lines))
6 years ago
(q #:in 'nw
#:out 'sw
6 years ago
#:offset (pt 0 (+ (quad-ref first-line 'inset-top 0)))
#:elems lines
6 years ago
#:size (delay (pt (pt-x (size first-line)) ;
6 years ago
(+ (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)
6 years ago
;; 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))
6 years ago
(quad-ref first-line 'border-color-left) bw-left))
6 years ago
#:draw-end (if draw-debug-block?
(λ (q doc) (draw-debug q doc "#6c6" "#9c9"))
void)))
6 years ago
6 years ago
(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
6 years ago
#:soft-break (λ (q) #true)
6 years ago
#:no-break (λ (q) (quad-ref q 'no-pbr))
6 years ago
#:distance (λ (q dist-so-far wrap-qs)
;; do trial block insertions
(for/sum ([x (in-list (insert-blocks wrap-qs))])
(pt-y (size x))))
6 years ago
#: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)]
6 years ago
[elems (insert-blocks lns)])))))
6 years ago
6 years ago
(define (insert-blocks lines)
6 years ago
(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)
6 years ago
[#false line-group]
[_ (list (block-wrap line-group))]))))
6 years ago
(define (run xs path)
(define pdf (time-name make-pdf (make-pdf #:compress #t
#:auto-first-page #f
6 years ago
#:output-path path
6 years ago
#:width (if zoom-mode? 350 612)
#:height (if zoom-mode? 400 792))))
6 years ago
(define line-width (- (pdf-width pdf) (* 2 side-margin)))
(define vertical-height (- (pdf-height pdf) top-margin bottom-margin))
6 years ago
(let* ([x (time-name atomize (atomize (qexpr->quad xs)))]
6 years ago
[x (time-name ->string-quad (map (λ (x) (->string-quad pdf x)) x))]
6 years ago
[x (time-name line-wrap (line-wrap x line-width))]
6 years ago
[x (time-name apply-keeps (apply-keeps x))]
[x (time-name page-wrap (page-wrap x vertical-height path))]
6 years ago
[x (time-name position (position (struct-copy quad q:doc [elems x])))])
6 years ago
(time-name draw (draw x pdf))))
6 years ago
(define-syntax (mb stx)
(syntax-case stx ()
6 years ago
[(_ PDF-PATH . STRS)
#'(#%module-begin
6 years ago
;; stick an nbsp in the strings so we have one printing char
6 years ago
(define strs (match (list . STRS)
[(? null?) '(" ")]
[strs strs]))
6 years ago
(define qx (list* 'q null (add-between strs pbr)))
6 years ago
(run qx PDF-PATH))]))
6 years ago
6 years ago
(module+ reader
(require scribble/reader syntax/strip-context (only-in markdown parse-markdown)
racket/match txexpr)
(provide (rename-out [quad-read-syntax read-syntax]))
6 years ago
6 years ago
6 years ago
(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])))
6 years ago
(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))
6 years ago
(define parsed-stx (datum->syntax stx (xexpr->parse-tree (parse-markdown (apply string-append (syntax->datum stx))))))
6 years ago
(strip-context
(with-syntax ([PT parsed-stx]
[PDF-PATH (path-replace-extension path-string #".pdf")])
#'(module _ qtest/markdown
PDF-PATH
. PT)))))