diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index aa106f45..3da05a16 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -113,25 +113,23 @@ [else ""]))) (define/typed+provide (gather-common-attrs qs) - ((Listof Quad) . -> . (U False HashableList)) - (: check-cap (QuadAttrPair . -> . Boolean)) - (define (check-cap cap) - (equal? (quad-attr-ref (car qs) (car cap) attr-missing) (cdr cap))) + ((Listof Quad) . -> . (Option HashableList)) + (: check-cap (Quad QuadAttrPair . -> . Boolean)) + (define (check-cap q cap) ; cap = candidate-attr-pair + (equal? (quad-attr-ref q (car cap) attr-missing) (cdr cap))) (let loop ([qs qs] - [common-attr-pairs : (Listof QuadAttrPair) (if (quad-attrs (car qs)) - + ;; start with the set of pairs in the first quad, then filter it down + [candidate-attr-pairs : (Listof QuadAttrPair) (if (quad-attrs (car qs)) (for/list ([kv-pair (in-hash-pairs (quad-attrs (car qs)))] #:unless (member (car kv-pair) cannot-be-common-attrs)) kv-pair) null)]) (cond - [(null? common-attr-pairs) #f] - [(null? qs) (cast (flatten common-attr-pairs) HashableList)] ;; flatten + cast needed because this output gets used by quadattrs + [(null? candidate-attr-pairs) #f] ; ran out of possible pairs, so return #f + [(null? qs) (cast (flatten candidate-attr-pairs) HashableList)] ; ran out of quads, so return common-attr-pairs ;; todo: reconsider type interface between output of this function and input to quadattrs - [else (loop (cdr qs) (filter check-cap common-attr-pairs))]))) - - + [else (loop (cdr qs) (filter (λ([cap : QuadAttrPair]) (check-cap (car qs) cap)) candidate-attr-pairs))]))) (: quadattrs ((Listof Any) . -> . QuadAttrs)) (define (quadattrs xs) diff --git a/quad/tests-typed.rkt b/quad/tests-typed.rkt index 43ee3b08..dff68531 100644 --- a/quad/tests-typed.rkt +++ b/quad/tests-typed.rkt @@ -9,9 +9,10 @@ (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) +(check-equal? (gather-common-attrs (list (box '(foo bar)) (box '(foo bar goo bar zam zino)) (box '(foo bar goo rab)))) '(foo bar)) +(check-false (gather-common-attrs (list (box) (box '(foo bar goo bar zam zino)) (box '(foo bar))))) +(check-false (gather-common-attrs (list (box '(width bar)) (box '(width bar)) (box '(width bar))))) +(check-false (gather-common-attrs (list (box '(foo bar)) (box '(foo zam))))) (define b1 (box '(x 10.0) "1st" (box '(foo bar) "2nd") "3rd")) (define b1-flattened (list (box '(x 10.0) "1st") (box '(x 10.0 foo bar) "2nd") (box '(x 10.0) "3rd")))