diff --git a/quad/qtest/fark.rkt b/quad/qtest/fark.rkt index d6fbbb46..044eaa1b 100644 --- a/quad/qtest/fark.rkt +++ b/quad/qtest/fark.rkt @@ -1,5 +1,18 @@ #lang qtest/markdown -x - -y \ No newline at end of file +So why did his sister not go and join the others? She had probably +only just got up and had not even begun to get dressed. And why was +she crying? Was it because he had not got up, and had not let the +chief clerk in, because he was in danger of losing his job and if +that happened his boss would once more pursue their parents with the +same demands as before? There was no need to worry about things like +that yet. Gregor was still there and had not the slightest +intention of abandoning his family. For the time being he just lay +there on the carpet, and no-one who knew the condition he was in +would seriously have expected him to let the chief clerk in. It was +only a minor discourtesy, and a suitable excuse could easily be +found for it later on, it was not something for which Gregor could +be sacked on the spot. And it seemed to Gregor much more sensible +to leave him now in peace instead of disturbing him with talking at +him and crying. But the others didn't know what was happening, they +were worried, that would excuse their behaviour. diff --git a/quad/qtest/markdown.rkt b/quad/qtest/markdown.rkt index 0eedf6fc..e4faeaaa 100644 --- a/quad/qtest/markdown.rkt +++ b/quad/qtest/markdown.rkt @@ -1,6 +1,6 @@ #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) + 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 @@ -18,7 +18,7 @@ (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)) + (qexpr (append `((keep-first "2")(keep-last "3") (hyphenate "true") (display ,(symbol->string (gensym)))) attrs) exprs)) (define-tag-function (hr attrs exprs) hrbr) @@ -229,8 +229,22 @@ (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))) +(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))] + [hstr (in-value (hyphenate str + #:min-left-length 4 + #:min-right-length 4 + #:min-hyphens 1))] + [substr (in-list (regexp-match* #rx"(-|\u00AD)" hstr #:gap-select? #t))]) + (struct-copy quad q [elems (list substr)]))])))) + +(define (line-wrap qs wrap-size) + (wrap (handle-hyphenate 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? @@ -543,6 +557,7 @@ (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 hyphenate (handle-hyphenate x))] [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))] diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 919cb929..b5041530 100644 --- a/quad/quad/atomize.rkt +++ b/quad/quad/atomize.rkt @@ -33,7 +33,7 @@ (define (merge-and-isolate-white str) (for/list ([(m idx) (in-indexed (regexp-match* whitespace-pat str #:gap-select? #t))] #:when (non-empty-string? m)) - (if (even? idx) m " "))) + (if (even? idx) m " "))) (define (merge-adjacent-strings xs [isolate-white? #false]) (let loop ([xs xs][acc null]) @@ -55,35 +55,34 @@ ;; which are multi-character quads with the same formatting. (define atomized-qs (let loop ([x (make-quad qx)] - [attrs (hash-copy (current-default-attrs))] - [key (eq-hash-code (current-default-attrs))]) - (match-define-values (next-key next-attrs) - ;; make a new run when we encounter non-empty attrs - (match (quad-attrs x) - [(? hash-empty?) (values key attrs)] - [this-attrs (define next-key (eq-hash-code this-attrs)) - (define next-attrs (attrs . update-with . this-attrs)) - (hash-set! next-attrs run-key next-key) - (attrs-proc next-attrs) - (values next-key next-attrs)])) - (match (quad-elems x) - [(? pair? elems) - ;; we don't use `struct-copy` here because it needs to have the structure id at compile time. - ;; whereas with this technique, we can extract a constructor for any structure type. - ;; notice that the technique depends on - ;; 1) we only need to update attrs and elems - ;; 2) we make them the first two fields, so we know to drop the first two fields of x-tail - (define x-maker (let-values ([(x-structure-type _) (struct-info x)]) - (struct-type-make-constructor x-structure-type))) - (define x-tail (drop (struct->list x) 2)) - (append* - (for/list ([elem (in-list (merge-adjacent-strings elems 'isolate-white))]) - (if (string? elem) - (if (zero? (string-length elem)) - null - (list (apply x-maker next-attrs (list elem) x-tail))) - (loop elem next-attrs next-key))))] - [_ ((quad-attrs x) . update-with! . next-attrs) (list x)]))) + [attrs (hash-copy (current-default-attrs))] + [key (eq-hash-code (current-default-attrs))]) + (match-define-values (next-key next-attrs) + ;; make a new run when we encounter non-empty attrs + (match (quad-attrs x) + [(? hash-empty?) (values key attrs)] + [this-attrs (define next-key (eq-hash-code this-attrs)) + (define next-attrs (attrs . update-with . this-attrs)) + (hash-set! next-attrs run-key next-key) + (attrs-proc next-attrs) + (values next-key next-attrs)])) + (match (quad-elems x) + [(? pair? elems) + ;; we don't use `struct-copy` here because it needs to have the structure id at compile time. + ;; whereas with this technique, we can extract a constructor for any structure type. + ;; notice that the technique depends on + ;; 1) we only need to update attrs and elems + ;; 2) we make them the first two fields, so we know to drop the first two fields of x-tail + (define x-maker (let-values ([(x-structure-type _) (struct-info x)]) + (struct-type-make-constructor x-structure-type))) + (define x-tail (drop (struct->list x) 2)) + (append* + (for/list ([elem (in-list (merge-adjacent-strings elems 'isolate-white))]) + (match elem + ["" null] + [(? string? str) (list (apply x-maker next-attrs (list str) x-tail))] + [_ (loop elem next-attrs next-key)])))] + [_ ((quad-attrs x) . update-with! . next-attrs) (list x)]))) #;(trimf atomized-qs (λ (q) (equal? (quad-elems q) '(" ")))) atomized-qs)