reasoning

quad/qtest/fark.rkt

@@ -1,5 +1,18 @@
 #lang qtest/markdown
 
-x
-
-y
+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.

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))]

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)