fix splitter

quad/quad/split.rkt

@@ -3,43 +3,43 @@
 
 ;; push together multiple attr sources into one list of pairs.
 ;; mostly a helper function for the two attr functions below.
-(define (join-attrs quads-or-attrs-or-lists)
-  (append-map hash->list (filter-not false? (map (λ(x)
-                                                   (cond
-                                                     [(quad? x) (quad-attrs x)]
-                                                     [(quad-attrs? x) x]
-                                                     #;[(hashable-list? x) (apply hash x)]
-                                                     [else #f])) quads-or-attrs-or-lists))))
+#;(define (join-attrs quads-or-attrs-or-lists)
+    (append-map hash->list (filter-not false? (map (λ(x)
+                                                     (cond
+                                                       [(quad? x) (quad-attrs x)]
+                                                       [(quad-attrs? x) x]
+                                                       #;[(hashable-list? x) (apply hash x)]
+                                                       [else #f])) quads-or-attrs-or-lists))))
 
 
 ;; flatten merges attributes, but applies special logic suitable to flattening
 ;; for instance, resolving x and y coordinates.
-(define (flatten-attrs . quads-or-attrs-or-falses)
-  (define all-attrs (join-attrs quads-or-attrs-or-falses))
-  (define-values (x-attrs y-attrs other-attrs-reversed)
-    (for/fold ([xas null][yas null][oas null])([attr (in-list all-attrs)])
-      (cond
-        [(equal? (car attr) 'x) (values (cons attr xas) yas oas)]
-        [(equal? (car attr) 'y) (values xas (cons attr yas) oas)]
-        [else (values xas yas (cons attr oas))])))
-  (define (make-cartesian-attr key attrs) (if (empty? attrs) empty (cons key (apply + (map cdr attrs)))))
-  (define-values (x-attr y-attr) (apply values (map make-cartesian-attr (list 'x 'y) (list x-attrs y-attrs))))
-  (apply hash (flatten (list* x-attr y-attr (reverse other-attrs-reversed)))))
+#;(define (flatten-attrs . quads-or-attrs-or-falses)
+    (define all-attrs (join-attrs quads-or-attrs-or-falses))
+    (define-values (x-attrs y-attrs other-attrs-reversed)
+      (for/fold ([xas null][yas null][oas null])([attr (in-list all-attrs)])
+        (cond
+          [(equal? (car attr) 'x) (values (cons attr xas) yas oas)]
+          [(equal? (car attr) 'y) (values xas (cons attr yas) oas)]
+          [else (values xas yas (cons attr oas))])))
+    (define (make-cartesian-attr key attrs) (if (empty? attrs) empty (cons key (apply + (map cdr attrs)))))
+    (define-values (x-attr y-attr) (apply values (map make-cartesian-attr (list 'x 'y) (list x-attrs y-attrs))))
+    (apply hash (flatten (list* x-attr y-attr (reverse other-attrs-reversed)))))
 
 ;; pushes attributes down from parent quads to children, 
 ;; resulting in a flat list of quads.
-(define (flatten-quad q)
-  (flatten
-   (let loop ([x q][parent #f])
-     (cond       
-       [(quad? x)
-        (let ([x-with-parent-attrs (quad (quad-name x) 
-                                         (flatten-attrs parent x) ; child positioned last so it overrides parent attributes 
-                                         (quad-list x))])
-          (if (empty? (quad-list x))
-              x-with-parent-attrs ; no subelements, so stop here
-              (map (λ(xi) (loop xi x-with-parent-attrs)) (quad-list x))))] ; replace quad with its elements
-       [(string? x) (quad (quad-name parent) (quad-attrs parent) (list x))]))))
+#;(define (flatten-quad q)
+    (flatten
+     (let loop ([x q][parent #f])
+       (cond       
+         [(quad? x)
+          (let ([x-with-parent-attrs (quad (quad-name x) 
+                                           (flatten-attrs parent x) ; child positioned last so it overrides parent attributes 
+                                           (quad-list x))])
+            (if (empty? (quad-list x))
+                x-with-parent-attrs ; no subelements, so stop here
+                (map (λ(xi) (loop xi x-with-parent-attrs)) (quad-list x))))] ; replace quad with its elements
+         [(string? x) (quad (quad-name parent) (quad-attrs parent) (list x))]))))
 
 
 
@@ -47,24 +47,29 @@
 ;; flatten quad as above, 
 ;; then dissolve it into individual character quads while copying attributes
 
-(define (split-quad q)
-  (letrec ([do-explode (λ(x [parent #f])
-                         (cond
-                           [(quad? x)
-                            (if (empty? (quad-list x))
-                                x ; no subelements, so stop here
-                                (map (λ(xi) (do-explode xi x)) (quad-list x)))] ; replace quad with its elements, exploded
-                           ;; todo: figure out why newlines foul up the input stream. Does it suffice to ignore them? 
-                           [else (map (λ(xc) (quad 'atom (quad-attrs parent) (list xc))) (regexp-match* #px"[^\r\n]" x))]))])
-    (flatten (map do-explode (flatten-quad q)))))
+#;(define (split-quad q)
+    (letrec ([do-explode (λ(x [parent #f])
+                           (cond
+                             [(quad? x)
+                              (if (empty? (quad-list x))
+                                  x ; no subelements, so stop here
+                                  (map (λ(xi) (do-explode xi x)) (quad-list x)))] ; replace quad with its elements, exploded
+                             ;; todo: figure out why newlines foul up the input stream. Does it suffice to ignore them? 
+                             [else (map (λ(xc) (quad 'atom (quad-attrs parent) (list xc))) (regexp-match* #px"[^\r\n]" x))]))])
+      (flatten (map do-explode (flatten-quad q)))))
 
 (require (for-syntax syntax/strip-context sugar/debug))
+(define-for-syntax ctx #'here)
 (define-syntax (stx-quad stx)
   (syntax-case stx ()
-    [(_ ((ATTR-NAME ATTR-VAL) ...) XS)
-     (with-syntax ([(NEW-ATTR-NAME ...) (map (λ(an) (replace-context #'here an)) (syntax->list #'(ATTR-NAME ...)))])
+    [(_ QUAD-NAME ((ATTR-NAME ATTR-VAL) ...) XS)
+     (with-syntax ([(NEW-ATTR-NAME ...) (map (λ(an) (datum->syntax stx (syntax->datum an))) (syntax->list #'(ATTR-NAME ...)))]
+                   [(ALL-ATTR-NAME ...) (map (λ(n) (datum->syntax stx n)) '(size font))])
        #'(let ([NEW-ATTR-NAME ATTR-VAL] ...)
-           (for-each (λ(x) (println (list size x))) XS)))]))
+           (append-map (λ(x) (if (string? x)
+                                 (for/list ([c (in-string x)])
+                                           (vector ALL-ATTR-NAME ... c))
+                                 x)) XS)))]))
 
 
 (require racket/generator)
@@ -75,5 +80,7 @@
 (split-quad x)
 |#
 
-(define x2 (stx-quad ((size 10)) (list "bar" (stx-quad ((size 8)) '("zam")) "qux")))
-x2
+;(define x2 (stx-quad ((size 10)(font "Eq")) (list "bar" (stx-quad ((size 8)) '("zam")) "qux")))
+;x2
+
+(stx-quad 'foo ((size 10)(font "Eq")) (list "bar" (stx-quad 'foo ((size 8)) '("zam")) "qux"))