diff --git a/quad/qtest/hyphenate.rkt b/quad/qtest/hyphenate.rkt index a7796948..baa28efe 100644 --- a/quad/qtest/hyphenate.rkt +++ b/quad/qtest/hyphenate.rkt @@ -14,13 +14,15 @@ At the command line: We said `raco pkg install hyphenate` dude -What?! ``` Code block Goes here ``` + +What?! + > Hyphenate `xexpr` by calculating hyphenation points and inserting `joiner` at those points. By default, `joiner` is the soft hyphen \(Unicode 00AD = decimal 173\). Words shorter than diff --git a/quad/qtest/markdown.rkt b/quad/qtest/markdown.rkt index 33c2572b..09664e33 100644 --- a/quad/qtest/markdown.rkt +++ b/quad/qtest/markdown.rkt @@ -3,13 +3,25 @@ pitfall quad sugar/debug pollen/tag) (provide (except-out (all-from-out racket/base) #%module-begin) (rename-out [mb #%module-begin]) - p id strong em attr-list h1 h2 code pre a blockquote) + p id strong em attr-list h1 h2 h3 h4 h5 h6 + ol li ul rsquo lsquo rquo lquo hellip + hr + code pre a blockquote) + +(define rsquo "’") +(define rquo "”") +(define lsquo "‘") +(define lquo "“") +(define hellip "…") (define-tag-function (p attrs exprs) (qexpr attrs exprs)) +(define-tag-function (hr attrs exprs) + (qexpr (cons '(hrule "yes") attrs) '(" "))) + (define-tag-function (blockquote attrs exprs) - (qexpr (cons '(container "bq") attrs) exprs)) + (qexpr (list* '(container "bq") '(left-inset "5") attrs) exprs)) (define id (default-tag-function 'id)) (define class (default-tag-function 'class)) @@ -25,11 +37,16 @@ (define-syntax-rule (attr-list . attrs) 'attrs) -(define-tag-function (h1 attrs exprs) - (qexpr (append '((font "fira")(fontsize "36")(line-height "48")) attrs) exprs)) +(define (heading-base font-size attrs exprs) + (qexpr (append '((font "fira")(fontsize (number->string font-size))(line-height (number->string (+ 12 font-size)))) attrs) exprs)) + +(define-tag-function (h1 attrs exprs) (heading-base 30 attrs exprs)) +(define-tag-function (h2 attrs exprs) (heading-base 24 attrs exprs)) +(define-tag-function (h3 attrs exprs) (heading-base 18 attrs exprs)) -(define-tag-function (h2 attrs exprs) - (qexpr (append '((font "fira")(fontsize "24")(line-height "36")) attrs) exprs)) +(define h4 h3) +(define h5 h3) +(define h6 h3) (define-tag-function (code attrs exprs) (qexpr (append '((font "fira-mono")(fontsize "11")(bg "aliceblue")) attrs) exprs)) @@ -41,7 +58,18 @@ [str (in-list (string-split (car (get-elements expr)) "\n"))]) `(,(get-tag expr) ,(get-attrs expr) ,str)) lbr)) - (qexpr attrs new-exprs)) + (qexpr (list* '(container "codeblock") '(left-inset "12") '(right-inset "12") attrs) new-exprs)) + +(define (list-base attrs exprs [bullet-val #f]) + (qexpr (list* '(left-inset "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 @@ -59,7 +87,7 @@ (match-define (list x y) (quad-origin q)) (text doc str x y #:bg (hash-ref (quad-attrs q) 'bg #f) #:link (hash-ref (quad-attrs q) 'link #f))) - #:draw-end (λ (q doc) (draw-debug q doc "#99f" "#ccf")))) + #: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") @@ -96,9 +124,9 @@ (define str (car (quad-elems q))) (pt (string-width doc str) (current-line-height doc)))])])) -(define draw? #f) +(define draw-debug? #t) (define (draw-debug q doc [fill-color "#f99"] [stroke-color "#fcc"]) - (when draw? + (when draw-debug? (save doc) (line-width doc 0.5) (apply rect doc (append (quad-origin q) (size q))) @@ -121,8 +149,7 @@ (define q:line-spacer (q #:type line-spacer #:size (pt 380 (* line-height 0.6)) #:out 'sw - #:printable (λ (q sig) - (not (memq sig '(start end)))) + #:printable (λ (q sig) (not (memq sig '(start end)))) #:draw-start draw-debug)) (define softies (map string '(#\space #\- #\u00AD))) @@ -150,39 +177,66 @@ ;; 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 (line-wrap xs size) - (wrap xs size +(define (line-wrap xs wrap-size) + (wrap xs (λ (q idx) (- wrap-size (string->number (quad-ref q 'left-inset "0")) + (string->number (quad-ref q 'right-inset "0")))) #:hard-break line-break? #:soft-break soft-break-for-line? - #:finish-wrap (λ (pcs q idx) - (define new-elems (consolidate-runs pcs)) - (append - (list (struct-copy quad q:line - [attrs (let ([attrs (hash-copy (quad-attrs q:line))]) - (define container-val (hash-ref (quad-attrs (car new-elems)) 'container #f)) - (when (and container-val - (for/and ([elem (in-list (cdr new-elems))]) - (equal? (hash-ref (quad-attrs elem) 'container #f) - container-val))) - (hash-set! attrs 'container container-val)) - attrs)] - [size (let () - (define line-heights - (filter-map - (λ (q) (string->number (hash-ref (quad-attrs q) 'line-height "NaN"))) - pcs)) - (match-define (list w h) (quad-size q:line)) - ;; when `line-heights` is empty, this is just h - (pt w (apply max (cons h line-heights))))] - [elems new-elems])) - (if (para-break? q) - (list q:line-spacer) - null))))) + #:finish-wrap + (λ (pcs q idx) + (define new-elems (consolidate-runs pcs)) + (append + (list (struct-copy quad q:line + [attrs (let ([attrs (hash-copy (quad-attrs q:line))]) + (define container-val (quad-ref (car new-elems) 'container)) + (when (and container-val + (for/and ([elem (in-list (cdr new-elems))]) + (equal? (quad-ref elem 'container) + container-val))) + (hash-set! attrs 'container container-val)) + attrs)] + [size (let () + (define line-heights + (filter-map + (λ (q) (string->number (quad-ref q 'line-height "NaN"))) + pcs)) + (match-define (list w h) (quad-size q:line)) + ;; when `line-heights` is empty, this is just h + (pt w (apply max (cons h line-heights))))] + [elems new-elems] + [offset (pt + (string->number (quad-ref (car new-elems) 'left-inset "0")) + (second (quad-offset q:line)))] + [draw-start (if (quad-ref (car new-elems) 'hrule) + (λ (dq doc) + (save 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 wrap-size 0) + (line-width doc 3) + (stroke doc "#999") + (restore doc)) + void)] +[draw-end (match (and (or (para-break? q) (not q)) + (quad-ref (car new-elems) 'list-index)) + [#false void] + [val (λ (q doc) + (save doc) + (translate doc (- (string->number (quad-ref (car new-elems) 'left-inset "0"))) 0) + (text doc val) + (restore doc))])])) +(if (para-break? q) + (list q:line-spacer) + null))))) (define top-margin 60) (define bottom-margin 120) @@ -221,6 +275,35 @@ (fill-and-stroke doc "#eee" "#999") (restore doc)))) +(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]) @@ -263,6 +346,7 @@ (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]))) @@ -275,7 +359,7 @@ (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 line-wrap #R (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])))]) @@ -285,7 +369,8 @@ (syntax-case stx () [(_ PDF-PATH . STRS) #'(#%module-begin - (define qx (list* 'q '((font "Charter") (fontsize "12")) (add-between (list . STRS) pbr))) + ;; stick an nbsp in the strings so we have one printing char + (define qx (list* 'q '((font "Charter") (fontsize "12")) (add-between (cons " " (list . STRS)) pbr))) (run qx PDF-PATH))])) (module+ reader @@ -310,7 +395,7 @@ #: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)))))) + (define parsed-stx (datum->syntax stx #R (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")]) diff --git a/quad/quad/qexpr.rkt b/quad/quad/qexpr.rkt index d79e2f41..8bb05602 100644 --- a/quad/quad/qexpr.rkt +++ b/quad/quad/qexpr.rkt @@ -79,7 +79,10 @@ [(cons (? valid-tag?) rest) (match rest [(list (? txexpr-attrs? attrs) (? qexpr? elems) ...) - (q #:attrs (attrs->hash attrs) #:elems (map loop elems))] + (define mheq (make-hash)) + (for ([attr-pair (in-list attrs)]) + (apply hash-set! mheq attr-pair)) + (q #:attrs mheq #:elems (map loop elems))] [(list (? qexpr? elems) ...) (q #:elems (map loop elems))])] [_ x]))) diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index ab910d72..78c5a4aa 100644 --- a/quad/quad/quad.rkt +++ b/quad/quad/quad.rkt @@ -6,7 +6,7 @@ (define (size q) (match (quad-size q) - [(? procedure? proc) (proc q)] + [(? procedure? proc) #R proc (proc q)] [(? promise? prom) (force prom)] [val val])) @@ -59,6 +59,9 @@ (define (hash-proc h recur) (equal-hash-code h)) (define (hash2-proc h recur) (equal-secondary-hash-code h))]) +(define (quad-ref q key [default-val #f]) + (hash-ref (quad-attrs q) key default-val)) + (define (default-printable q [sig #f]) #t) (define (default-draw q surface) diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt index df7d19be..9f24c1db 100644 --- a/quad/quad/wrap.rkt +++ b/quad/quad/wrap.rkt @@ -18,12 +18,16 @@ (append partial (dropf wrap nonprinting-soft-break-in-middle?))) (define (wrap qs - [target-size (current-wrap-distance)] + [target-size-proc-arg (current-wrap-distance)] [debug #f] #:hard-break [hard-break? (λ (x) #f)] #:soft-break [soft-break? (λ (x) #f)] #:wrap-anywhere? [wrap-anywhere? #f] #:finish-wrap [finish-wrap-proc (λ (xs q idx) (list xs))]) + (define target-size-proc + (match target-size-proc-arg + [(? procedure? proc) proc] + [val (λ (q idx) val)])) ; takes quads in wrap, triggering quad, and wrap idx; returns list containing wrap (and maybe other things) (define (finish-wrap qs wrap-idx [wrap-triggering-q (car qs)]) ;; reverse because quads accumulated in reverse @@ -81,7 +85,7 @@ other-qs)])] [else ; cases that require computing distance (define dist (if (printable? q) (distance q) 0)) - (define would-overflow? (and current-dist (> (+ dist current-dist) target-size))) + (define would-overflow? (and current-dist (> (+ dist current-dist) (target-size-proc q wrap-idx)))) (cond [would-overflow? (cond