From 1dd58b2f5f8a166b81376b66ec9abd777451be74 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sat, 7 Mar 2015 09:26:58 -0800
Subject: [PATCH] hyphenate, polymorphize split-at-last

---
 quad/main-typed.rkt  | 11 +++++++++++
 quad/utils-typed.rkt | 26 +++++++++++++++++++++++---
 quad/wrap-typed.rkt  |  7 ++++---
 3 files changed, 38 insertions(+), 6 deletions(-)

diff --git a/quad/main-typed.rkt b/quad/main-typed.rkt
index 0d874db3..623626f4 100644
--- a/quad/main-typed.rkt
+++ b/quad/main-typed.rkt
@@ -25,3 +25,14 @@
         [(block-break? q) (values multipages multicolumns (cons-reverse block-acc blocks) empty)]
         [else (values multipages multicolumns blocks (cons q block-acc))])))
   (reverse (cons-reverse (cons-reverse ((inst cons-reverse Quad Block-Type) b bs) mcs) mps)))
+
+
+(define/typed (merge-adjacent-within q)
+  (Quad . -> . Quad)
+  (quad (quad-name q) (quad-attrs q) (join-quads (cast (quad-list q) (Listof Quad)))))
+
+(define/typed (hyphenate-quad-except-last-word q)
+  (Quad . -> . Quad)
+  (log-quad-debug "last word will not be hyphenated")
+  (define-values (first-quads last-quad) (split-last (quad-list q)))
+  (quad (quad-name q) (quad-attrs q) (snoc (map hyphenate-quad first-quads) last-quad)))
diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt
index 2b75df16..9130563e 100644
--- a/quad/utils-typed.rkt
+++ b/quad/utils-typed.rkt
@@ -1,9 +1,15 @@
 #lang typed/racket/base
 (require/typed sugar/list [slice-at ((Listof (U QuadAttrKey QuadAttrValue)) Positive-Integer . -> . (Listof (List QuadAttrKey QuadAttrValue)))])
 (require/typed racket/list [flatten (All (A) (Rec as (U Any (Listof as))) -> (Listof Any))])
-(require (for-syntax racket/syntax racket/base) racket/string (except-in racket/list flatten) sugar/debug racket/bool hyphenate racket/function math/flonum)
+(require/typed hyphenate [hyphenate (String #:min-length Nonnegative-Integer #:min-left-length Nonnegative-Integer #:min-right-length Nonnegative-Integer . -> . String)])
+(require (for-syntax racket/syntax racket/base) racket/string (except-in racket/list flatten) sugar/debug racket/bool racket/function math/flonum)
 (require "quads-typed.rkt" "world-typed.rkt" "measure-typed.rkt")
 
+(provide quad-map)
+(define/typed (quad-map proc q)
+  ((QuadListItem . -> . QuadListItem) Quad . -> . Quad)
+  (quad (quad-name q) (quad-attrs q) (map proc (quad-list q))))
+
 
 ;; predicate for use below
 (: list-of-mergeable-attrs? (Any . -> . Boolean))
@@ -214,9 +220,23 @@
             result))))
 
 
+;; recursively hyphenate strings in a quad
+(provide hyphenate-quad)
+(define/typed (hyphenate-quad x)
+  (QuadListItem . -> . QuadListItem)
+  (cond
+    [(quad? x) (quad-map hyphenate-quad x)]
+    [(string? x) (hyphenate x
+                            #:min-length 6	 	 	 	 
+                            #:min-left-length 3	 	 	 	 
+                            #:min-right-length 3)]
+    [else x]))
+
+;; just because it comes up a lot
 (provide split-last)
-(define (split-last xs)
-  (let-values ([(first-list last-list) ((inst split-at-right Any) (cast xs (Listof Any)) 1)])
+(define/typed (split-last xs)
+  (All (A) ((Listof A) -> (values (Listof A) A)))
+  (let-values ([(first-list last-list) ((inst split-at-right A) xs 1)])
     (values first-list (car last-list))))
 
 ;; like cons, but joins a list to an atom
diff --git a/quad/wrap-typed.rkt b/quad/wrap-typed.rkt
index 120e9265..db505da4 100644
--- a/quad/wrap-typed.rkt
+++ b/quad/wrap-typed.rkt
@@ -82,9 +82,10 @@
   (define-values (breakable-items items-to-make-unbreakable) (split-at-right qs (min world:minimum-last-line-chars (length qs))))
   (define unbreak-qs (append breakable-items (map make-unbreakable items-to-make-unbreakable)))
   (define lists-of-quads (slicef-after unbreak-qs (λ(q) (and (possible-word-break-quad? (cast q Quad)) (not (quad-attr-ref (cast q Quad) world:unbreakable-key #f))))))
-  (define-values (first-lists-of-quads last-list-of-quads) (split-last lists-of-quads))
-  (define (make-first-pieces qs)
-    (let-values ([(first-qs last-q) (split-last qs)])
+  (define-values (first-lists-of-quads last-list-of-quads) ((inst split-last (Listof Quad)) lists-of-quads))
+  (define/typed (make-first-pieces qs)
+    ((Listof Quad) . -> . Quad) 
+    (let-values ([(first-qs last-q) ((inst split-last Quad) qs)])
       (apply piece (list world:word-break-key (convert-to-word-break (cast last-q Quad))) (cast first-qs QuadList))))
   (append (map make-first-pieces first-lists-of-quads) 
           (list (apply piece #f (cast last-list-of-quads QuadList)))))