keep hope alive

quad/quad/atomize.rkt

@@ -1,47 +1,42 @@
-#lang quad/dev
-(require racket/string hyphenate)
+#lang racket/base
+(require racket/contract racket/match racket/list txexpr sugar/debug
+         "qexpr.rkt")
 (provide (all-defined-out))
 
-(define (atomize x)
-  (apply
-   vector-immutable
-   (flatten
-    (list
-     (let loop ([x x][loop-attrs default-attrs])
-       (cond
-         [($shim? x) x]
-         [(string? x)
-          ;; consolidate consecutive whitespaces into single word space
-          ;; todo: hyphenate here? then they are in the quad stream
-          (for/list ([c (in-string x)]) 
-                    (cons
-                     ;; installing loop attrs allows us to recognize contiguous runs later
-                     ($shim loop-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
-                     ;; and thus the measurement can be shared too?
-                     ;; (object would have to be packaged with other typographic specs)
-                     ((casev c
-                             [(#\space) $space]
-                             [(#\-) $hyphen]
-                             [(#\u00AD) $shy]
-                             [else $black]) loop-attrs #f c)))]
-         [else
-          (map (λ(xi) (loop xi ((quad-attrs x) . override-with . loop-attrs))) (quad-val x))]))
-     ($eof (make-empty-attrs) #f #f))))) ; add eof so any in-vector loop consumes all the input vals
-
-(define (merge-runs xs)
-  ; combine quads with same attrs into sublists
-  (cond
-    [(empty? xs) empty]
-    [else
-     (define target (car xs))
-     (define-values (matches rest)
-       (splitf-at (cdr xs) (λ(x) (eq? (quad-attrs target) (quad-attrs x)))))
-     (list* (cons target matches) (merge-runs rest))]))
+(define/contract (atomize qx)
+  ;; normalize a qexpr by reducing it to one-character quads.
+  ;; propagate attrs downward by appending to front of attrs list.
+  ;; at then end, duplicates are removed, with frontmost attrs (= added later) given preference
+  (qexpr? . -> . (listof qexpr?))
+  (let loop ([x qx][attrs null])
+    (match x
+      [(? string?) (for/list ([c (in-string x)]) ;; strings are exploded
+                             (qexpr attrs (string c)))]
+      [(list (? symbol?) (? txexpr-attrs? new-attrs) xs ...) ;; qexprs with attributes are recursed
+       (append* (for/list ([x (in-list xs)])
+                          (loop x (append new-attrs attrs))))]
+      [(list (? symbol? tag) xs ...) (loop (list* tag null xs) attrs)] ;; qexprs without attributes get null attrs
+      [else (raise-argument-error 'atomize "valid item" x)])))
 
 (module+ test
   (require rackunit)
-  #;(atomize (quad (make-attrs #:size 10 #:font "Eq") "ba" (line-break) "r" (quad (make-attrs #:size 8) "zam") "q\tux"))
-  (define qs (atomize (quad #f "A" (page-break) "B")))
-  qs)
+  (check-equal? (atomize "Hi") '((q "H") (q "i")))
+  (check-equal? (atomize '(q "Hi " (q "You"))) '((q "H") (q "i") (q " ") (q "Y") (q "o") (q "u")))
+  (check-exn exn:fail? (λ () (atomize #t)))
+
+  ;; with attributes
+  (check-equal? (atomize '(q ((k "v")) "Hi")) '((q ((k "v")) "H") (q ((k "v")) "i")))
+  (check-equal? (atomize '(q ((k "v")) "Hi " (q "You")))
+                '((q ((k "v")) "H")
+                  (q ((k "v")) "i")
+                  (q ((k "v")) " ")
+                  (q ((k "v")) "Y")
+                  (q ((k "v")) "o")
+                  (q ((k "v")) "u")))
+  (check-equal? (atomize '(q ((k1 "v1")(k2 "42")) "Hi " (q ((k1 "v2")(k3 "foo")) "You")))
+                '((q ((k1 "v1")(k2 "42")) "H")
+                  (q ((k1 "v1")(k2 "42")) "i")
+                  (q ((k1 "v1")(k2 "42")) " ")
+                  (q ((k1 "v2")(k3 "foo")(k2 "42")) "Y")
+                  (q ((k1 "v2")(k3 "foo")(k2 "42")) "o")
+                  (q ((k1 "v2")(k3 "foo")(k2 "42")) "u"))))

quad/quad/qexpr.rkt

@@ -0,0 +1,51 @@
+#lang br
+(require xml racket/contract txexpr)
+(provide (all-defined-out))
+
+(module+ test (require rackunit))
+
+(define/contract (qexpr? x)
+  ;; a qexpr is like an xexpr, but more lenient in some ways (allows single char as body element)
+  ;; and less in others (only allows 'q or 'quad as tag names)
+  (any/c . -> . boolean?)
+  (define (valid-tag? tag) (and (memq tag '(q quad)) #t))
+  (match x
+    [(? txexpr?) (valid-tag? (get-tag x))]
+    [(list (? symbol? tag) (? char? c)) (valid-tag? tag)]
+    [(? string?) #t]
+    [else #f]))
+
+(module+ test
+  (check-true (qexpr? "Hello world"))
+  (check-true (qexpr? '(q "Hello world")))
+  (check-true (qexpr? '(quad "Hello world")))
+  (check-false (qexpr? '(div "Hello world")))
+  (check-true (qexpr? '(q #\H)))
+  (check-true (qexpr? '(quad #\H)))
+  (check-false (qexpr? '(span #\H)))
+  (check-true (qexpr? '(quad "Hello world")))
+  (check-false (qexpr? 'q)))
+
+(define/contract (qexpr attrs . elems)
+  ((txexpr-attrs?) #:rest txexpr-elements? . ->* . qexpr?)
+  (txexpr 'q (remove-duplicates attrs #:key car) elems))
+
+(module+ test
+  (check-equal? (qexpr null "foo") '(q "foo"))
+  (check-equal? (qexpr '((k "v")) "foo") '(q ((k "v")) "foo"))
+  (check-equal? (qexpr '((k "v2")(k "v1")) "foo") '(q ((k "v2")) "foo")))
+
+(define/contract (qml->qexpr x)
+  (string? . -> . qexpr?)
+  (parameterize ([permissive-xexprs #t]
+                 [xexpr-drop-empty-attributes #t])
+    (string->xexpr x)))
+
+(define/contract (qexpr->qml x)
+  (qexpr? . -> . string?)
+  (xexpr->string x))
+
+(module+ test
+  (check-equal? (qml->qexpr (qexpr->qml '(q "hi"))) '(q "hi"))
+  (check-equal? (qml->qexpr (qexpr->qml '(q () "hi"))) '(q "hi"))
+  (check-equal? (qml->qexpr (qexpr->qml '(q ((foo "bar")) "hi"))) '(q ((foo "bar")) "hi")))