diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index 0f6deb01..507bd9c1 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -4,7 +4,7 @@ ;; note to self: a require/typed function with proper typing ;; is faster than a generic function + type assertion at location of call (require/typed racket/list - [flatten ((Listof QuadAttr) . -> . HashableList)]) + [flatten ((Listof QuadAttr) . -> . QuadAttrs)]) (require/typed sugar/list [trimf (All (A) ((Listof A) (A . -> . Boolean) -> (Listof A)))] [filter-split (All (A) ((Listof A) (A . -> . Boolean) -> (Listof (Listof A))))]) (require/typed racket/string [string-append* ((Listof String) . -> . String)]) @@ -68,7 +68,10 @@ ;; funky implementation -(define-type+predicate Quad (Pairof QuadName (Pairof QuadAttrs (Listof (U String Quad))))) +;; Quad-Recursive works around a bug in the optimizer +;; see https://github.com/racket/typed-racket/issues/60 +(define-type Quad-Recursive (List* QuadName QuadAttrs (Listof (U String Quad-Recursive)))) +(define-type+predicate Quad (List* QuadName QuadAttrs (Listof (U String Quad-Recursive)))) (define-predicate quad? Quad) (define/typed (quad name attrs items) (QuadName QuadAttrs QuadList . -> . Quad) @@ -82,7 +85,7 @@ (define/typed (quad-attrs q) (Quad . -> . QuadAttrs) - (cadr q)) + (car (cdr q))) (define/typed (quad-attr-keys qas) (QuadAttrs . -> . (Listof QuadAttrKey)) @@ -92,17 +95,18 @@ (define/typed (quad-list q) (Quad . -> . QuadList) - (cddr q)) - + (cdr (cdr q))) (define/typed (quad-attr-ref q-or-qas key [default attr-missing]) (((U Quad QuadAttrs) QuadAttrKey) (QuadAttrValue) . ->* . QuadAttrValue) (define qas (if (quad? q-or-qas) (quad-attrs q-or-qas) q-or-qas)) (define qa-result (memf (λ([qap : QuadAttr]) (equal? key (car qap))) qas)) - (if qa-result + ;; empty check shouldn't be necessary but the memf return type is lax: #f or (Listof A) + ;; really it should be #f or (List* A (Listof A)) + (if (and qa-result (not (empty? qa-result))) ;; car beacause result of memf is a list tail; cadr because second element in pair - (cadr (car qa-result)) + (car (cdr (car qa-result))) (if (not (equal? default attr-missing)) default (error 'key-not-found)))) @@ -141,26 +145,27 @@ [else (string-append* ((inst map String QuadListItem) loop (quad-list x)))]))) (define/typed+provide (gather-common-attrs qs) - ((Listof Quad) . -> . (Option HashableList)) + ((Listof Quad) . -> . QuadAttrs) (: check-cap (Quad QuadAttr . -> . Boolean)) (define (check-cap q cap) ; cap = candidate-attr-pair (equal? (quad-attr-ref q (car cap) attr-missing) (cdr cap))) - (and (not (null? qs)) - (let loop - ([qs qs] - ;; start with the set of pairs in the first quad, then filter it down - [candidate-attr-pairs : (Listof QuadAttr) (let ([first-attrs (quad-attrs (car qs))]) - (if first-attrs - (for/fold ([kvps : QuadAttrs null]) ([k (in-list (quad-attr-keys first-attrs))]) - (if (member k cannot-be-common-attrs) - kvps - (cons (list k (quad-attr-ref first-attrs k)) kvps))) - null))]) - (cond - [(null? candidate-attr-pairs) #f] ; ran out of possible pairs, so return #f - [(null? qs) (flatten candidate-attr-pairs)] ; 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 (λ([cap : QuadAttr]) (check-cap (car qs) cap)) candidate-attr-pairs))])))) + (if (null? qs) + qs + (let loop + ([qs qs] + ;; start with the set of pairs in the first quad, then filter it down + [candidate-attr-pairs : (Listof QuadAttr) (let ([first-attrs (quad-attrs (car qs))]) + (if first-attrs + (for/fold ([kvps : QuadAttrs null]) ([k (in-list (quad-attr-keys first-attrs))]) + (if (member k cannot-be-common-attrs) + kvps + (cons (list k (quad-attr-ref first-attrs k)) kvps))) + null))]) + (cond + [(null? candidate-attr-pairs) null] ; ran out of possible pairs, so return #f + [(null? qs) (flatten candidate-attr-pairs)] ; 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 (λ([cap : QuadAttr]) (check-cap (car qs) cap)) candidate-attr-pairs))])))) (define/typed (make-quadattrs xs) ;; no point typing the input as (U QuadAttrKey QuadAttrValue) @@ -191,15 +196,15 @@ ((Listof Quad) . -> . Quad) (apply id (gather-common-attrs qs) qs)) - (define-type IdQuad (List 'id QuadAttrs QuadList)) + (define-type IdQuad (List* 'id QuadAttrs (Listof (U String Quad)))) (define-predicate IdQuad? IdQuad) (define id? IdQuad?) (define/typed (id [attrs '()] #:zzz [zzz 0] . xs) (() (QuadAttrs #:zzz Zero) #:rest QuadListItem . ->* . Quad) - (quad 'id (if (list? attrs) - (make-quadattrs attrs) - attrs) xs))))])) + (quad 'id (if (QuadAttrs? attrs) + attrs + (make-quadattrs attrs)) xs))))])) (define/typed (whitespace? x [nbsp? #f]) ((Any) (Boolean) . ->* . Boolean) @@ -256,7 +261,7 @@ (define-quad-type box) -#| + (define-quad-type spacer) (define-quad-type kern) (define-quad-type optical-kern) @@ -278,4 +283,4 @@ (define-break-type column) (define-break-type block) (define-break-type line) -|# +