diff --git a/quad/measure-typed.rkt b/quad/measure-typed.rkt index 0a619bbf..7b9fbd1d 100644 --- a/quad/measure-typed.rkt +++ b/quad/measure-typed.rkt @@ -48,7 +48,7 @@ (make-hash '())))) -(define-type mms-type ((String String) (Symbol Symbol) . ->* . (Listof Nonnegative-Flonum))) +(define-type mms-type ((String String) (Symbol Symbol) . ->* . (List Nonnegative-Flonum Nonnegative-Flonum Nonnegative-Flonum Nonnegative-Flonum))) (: measure-max-size mms-type) (define measure-max-size (cast (make-caching-proc (λ(text font [weight 'normal] [style 'normal]) diff --git a/quad/tests-typed.rkt b/quad/tests-typed.rkt index e203a0c7..e8d83d64 100644 --- a/quad/tests-typed.rkt +++ b/quad/tests-typed.rkt @@ -8,3 +8,15 @@ (check-equal? (flatten-attrs (box '(foo bar)) (hash 'x 10.0)) (apply hash '(foo bar x 10.0))) (check-equal? (flatten-attrs (hash 'x -5.0) (hash 'x 10.0)) (apply hash '(x 5.0))) (check-equal? (merge-attrs (hash 'x -5.0) (hash 'x 10.0)) (apply hash '(x 10.0))) + +(check-equal? (gather-common-attrs (list (box '(foo bar)) (box '(foo bar goo bar zam zino)) (box '(foo bar)))) (list (cons 'foo 'bar))) +(check-equal? (gather-common-attrs (list (box) (box '(foo bar goo bar zam zino)) (box '(foo bar)))) #f) +(check-equal? (gather-common-attrs (list (box '(width bar)) (box '(width bar)) (box '(width bar)))) #f) + +(define b1 (box '(x 10) "1st" (box '(foo bar) "2nd") "3rd")) +(define b1-flattened (list (box '(x 10) "1st") (box '(x 10 foo bar) "2nd") (box '(x 10) "3rd"))) + +(define b3 (box #f (word) (line) (page))) +(check-true (sequence? b3)) + +;(check-true (quad= (flatten-quad b1) b1-flattened)) diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 259fc28e..2eca8642 100644 --- a/quad/utils-typed.rkt +++ b/quad/utils-typed.rkt @@ -25,7 +25,7 @@ [(quad-attrs? x) (cast x QuadAttrs)] [(hashable-list? x) (quadattrs (cast x (Listof Any)))] [else ;; something that will have no effect on result - (cast hash QuadAttrs)])) quads-or-attrs-or-lists))) + (cast (hash) QuadAttrs)])) quads-or-attrs-or-lists))) ;; flatten merges attributes, but applies special logic suitable to flattening @@ -58,5 +58,29 @@ (provide merge-attrs) (: merge-attrs ((U Quad QuadAttrs HashableList) * . -> . QuadAttrs)) (define (merge-attrs . quads-or-attrs-or-lists) - (cast (for/hash ([kv-pair (in-list (join-attrs quads-or-attrs-or-lists))]) - (values (car kv-pair) (cdr kv-pair))) QuadAttrs)) + (for/hash : QuadAttrs ([kv-pair (in-list (join-attrs quads-or-attrs-or-lists))]) + (values (car kv-pair) (cdr kv-pair)))) + + + +;; pushes attributes down from parent quads to children, +;; resulting in a flat list of quads. +;; input is often large, so macro allows us to avoid allocation +#| +(provide flatten-quad) +(: flatten-quad (Quad . -> . (Listof Quad))) +(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))])))) + + +|# \ No newline at end of file