From 41cdc8d676e2ec83d8831d57ccdbb60265e0b537 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Mon, 20 Jun 2016 21:46:01 -0700
Subject: [PATCH] move string munging into quad constructor

---
 quad/quad/atomize.rkt |  4 ++--
 quad/quad/quads.rkt   | 56 +++++++++++++++++++++++++++++++++++++++----
 2 files changed, 54 insertions(+), 6 deletions(-)

diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt
index 65f5ef9d..7e595420 100644
--- a/quad/quad/atomize.rkt
+++ b/quad/quad/atomize.rkt
@@ -1,5 +1,5 @@
 #lang quad/dev
-(require racket/vector)
+(require racket/string)
 (provide (all-defined-out))
 
 (define (atomize x)
@@ -12,7 +12,7 @@
         [(symbol? x) ($hard empty-attrs x #f)]
         [(string? x)
          ;; consolidate consecutive whitespaces into single word space
-         (for/list ([c (in-string (regexp-replace* #px"\\s+" x " "))]) 
+         (for/list ([c (in-string x)]) 
                    (cons ($hard empty-attrs #f #f)
                          ;; todo: is it feasible to box or otherwise object-ize a char
                          ;; so that all the quads with that char share that object
diff --git a/quad/quad/quads.rkt b/quad/quad/quads.rkt
index af05b220..ea3b8051 100644
--- a/quad/quad/quads.rkt
+++ b/quad/quad/quads.rkt
@@ -1,6 +1,6 @@
 #lang racket/base
 (provide (all-defined-out))
-(require (for-syntax racket/string racket/base racket/syntax))
+(require racket/string racket/list (for-syntax  racket/base racket/syntax))
 
 (struct $quad (attrs dim val) #:transparent #:mutable)
 (struct $black $quad () #:transparent)
@@ -27,8 +27,48 @@ measure (line width)
 
 |#
 (define default-attrs (hasheq 'size 10 'font "sc.otf")) ; Source Code Pro, 12 pt, chars are 6pt wide
-(define (quad attr . xs)
-  ($quad (or attr (make-attrs)) 0 xs))
+
+(define (munge-whitespace str)
+  ;; reduce multiple whitespace to single
+  ;; trim remaining
+  (string-trim (regexp-replace* #px"\\s+" str " ")))
+
+(define (merge-strings xs)
+  ;; merge consecutive strings
+  (let loop ([xs xs])
+    (cond
+      [(empty? xs) empty]
+      [else
+       (define-values (strs rest) (splitf-at xs string?))
+       (define-values (nonstrs restrest) (splitf-at rest (λ(x) (not (string? x)))))
+       (append (if (empty? strs)
+                   empty
+                   (list (munge-whitespace (string-append* strs)))) nonstrs (loop restrest))])))
+
+#;(define (merge-strings1 xs)
+    ;; merge consecutive strings
+    (define-values (last-list list-of-lists last-negating)
+      (for/fold ([current-list empty]
+                 [list-of-lists empty]
+                 [negating? #f])
+                ([x (in-list xs)])
+        (define current-pred (if negating? (λ (x) (not (string? x))) string?))
+        (if (current-pred x)
+            (values (cons x current-list) list-of-lists negating?)
+            (values (cons x null) (if (not (empty? current-list))
+                                      (cons (reverse current-list) list-of-lists)
+                                      list-of-lists) (not negating?)))))
+    (append-map (λ(xs) (if (string? (car xs))
+                           (list (munge-whitespace (string-append* xs)))
+                           xs))
+                (reverse (cons (reverse last-list) list-of-lists))))
+
+#;(require sugar/list)
+#;(define (merge-strings xs)
+    (append-map (λ(xis) (if (string? (car xis))
+                            (list (munge-whitespace (string-append* xis)))
+                            xis)) (slicef xs string?)))
+
 
 (struct $attrs (size font) #:transparent)
 (define (make-attrs #:size [size #f]
@@ -36,6 +76,12 @@ measure (line width)
   (hasheq 'size size 'font font))
 
 
+(define (quad attr . xs)
+  ;; squeeze excess whitespace out of quad args
+  ;; todo: find way to do this with less allocation
+  ($quad (or attr (make-attrs)) 0 (merge-strings xs)))
+
+
 (define (quad-dim q)
   ($quad-dim q))
 
@@ -61,6 +107,7 @@ measure (line width)
 (define-break block-break)
 (define-break line-break)
 
+
 (define-syntax (caseq stx)
   ;; like case but strictly uses `eq?` comparison (as opposed to `equal?`)
   (syntax-case stx ()
@@ -79,4 +126,5 @@ measure (line width)
   (check-true (quad? q))
   (check-false (quad? 42))
   (check-equal? (quad-attrs q) (make-attrs))
-  (check-equal? (quad-val q) '("bar")))
\ No newline at end of file
+  (check-equal? (quad-val q) '("bar"))
+  (check-equal? (merge-strings '(50 " foo   " "   bar  " 42 "  zam")) '(50 "foo bar" 42 "zam")))
\ No newline at end of file