diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index 6ec0907a..833e9561 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 QuadAttrPair) . -> . HashableList)]) + [flatten ((Listof QuadAttr) . -> . HashableList)]) (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)]) @@ -50,11 +50,11 @@ (define-type id basetype) (define-predicate id? id)))])) -(define-type QuadName Symbol) +(define-type+predicate QuadName Symbol) (define-type+predicate QuadAttrKey Symbol) -(define-type QuadAttrValue Any) -(define-type QuadAttrs (HashTable QuadAttrKey QuadAttrValue)) -;;(define-predicate QuadAttrs? QuadAttrs) ;; won't work because it generates a chaperone contract +(define-type+predicate QuadAttrValue (U Float Index String Symbol)) +(define-type+predicate QuadAttr (List QuadAttrKey QuadAttrValue)) +(define-type+predicate QuadAttrs (Listof QuadAttr)) (provide HashableList?) (define-type+predicate HashableList (Rec duo (U Null (List* QuadAttrKey Any duo)))) @@ -62,28 +62,19 @@ (define (quad-attrs? x) (and (hash? x) (andmap QuadAttrKey? (hash-keys x)))) -(define-type+predicate QuadListItem (U String Quad)) +(define-type QuadListItem (U String Quad)) (define-type QuadList (Listof QuadListItem)) (define-type (Treeof A) (Rec as (U A (Listof as)))) -;; struct implementation - - -(struct quad ([name : QuadName] [attrs : QuadAttrs] [list : QuadList]) #:transparent) - -(define-type Quad quad) -(define-predicate Quad? Quad) - -#| -;; vector implementation - -(define-type Quad (List QuadName QuadAttrs QuadList)) -(define quad? Quad?) - -(define/typed (quad name attrs list) +;; funky implementation +(define-type+predicate Quad (List QuadName QuadAttrs (Listof (U String Quad)))) +(define-predicate quad? Quad) +(define/typed (quad name attrs items) (QuadName QuadAttrs QuadList . -> . Quad) - `(,name ,attrs ,list)) + (list name attrs items)) + +(define-type+predicate QuadSet (List QuadName QuadAttrs (Listof Quad))) (define/typed (quad-name q) (Quad . -> . QuadName) @@ -93,19 +84,24 @@ (Quad . -> . QuadAttrs) (cadr q)) +(define/typed (quad-attr-keys qas) + (QuadAttrs . -> . (Listof QuadAttrKey)) + (if (empty? qas) + qas + ((inst map QuadAttrKey QuadAttr) car qas))) + (define/typed (quad-list q) (Quad . -> . QuadList) (caddr q)) -|# +(define-type Thunker (-> Any)) +(define-predicate Thunker? Thunker) - -(define quad-attr-ref - (case-lambda - [([q : Quad] [key : QuadAttrKey]) - (hash-ref (quad-attrs q) key)] - [([q : Quad] [key : QuadAttrKey] [default : QuadAttrValue]) - (hash-ref (quad-attrs q) key (λ() default))])) +(define/typed (quad-attr-ref q-or-qas key [default (λ () (error 'key-not-found))]) + (((U Quad QuadAttrs) QuadAttrKey) ((U Thunker QuadAttrValue)) . ->* . QuadAttrValue) + (define qaps (if (quad? q-or-qas) (quad-attrs q-or-qas) q-or-qas)) + (define result (ormap (λ([qap : QuadAttr]) (and (equal? key (car qap)) (cdr qap))) qaps)) + (or result (if (Thunker? default) (default) default))) (define-syntax (quad-attr-ref/parameter stx) (syntax-case stx () @@ -115,7 +111,6 @@ (define cannot-be-common-attrs '(width x y page)) (define attr-missing (gensym)) -(define-type QuadAttrPair (Pairof QuadAttrKey QuadAttrValue)) (: quad-ends-with? (Quad String . -> . Boolean)) @@ -144,25 +139,25 @@ (define/typed+provide (gather-common-attrs qs) ((Listof Quad) . -> . (Option HashableList)) - (: check-cap (Quad QuadAttrPair . -> . Boolean)) + (: 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 QuadAttrPair) (let ([first-attrs (quad-attrs (car qs))]) + [candidate-attr-pairs : (Listof QuadAttr) (let ([first-attrs (quad-attrs (car qs))]) (if first-attrs - (for/fold ([kvps null]) ([k (in-list (hash-keys first-attrs))]) + (for/fold ([kvps : QuadAttrs null]) ([k (in-list (quad-attr-keys first-attrs))]) (if (member k cannot-be-common-attrs) kvps - (cons (cons k (hash-ref first-attrs k)) 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 : QuadAttrPair]) (check-cap (car qs) cap)) candidate-attr-pairs))])))) + [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) @@ -175,8 +170,8 @@ (values (cons x ks) vs #f) (values ks (cons x vs) #t)))]) (when (not even?) (error 'quadattrs "odd number of elements in ~a" xs)) - (for/hash : QuadAttrs ([k (in-list ks)][v (in-list vs)]) - (values k v)))) + (for/list : QuadAttrs ([k (in-list ks)][v (in-list vs)]) + (list k v)))) @@ -221,8 +216,10 @@ (quadattrs null)) xs)] [() (quad 'id (quadattrs null) null)])) - ;; IdQuad struct subtype - #;(struct IdQuad Quad () #:transparent) + ;; IdQuad subtype + (define-type IdQuad (List 'id QuadAttrs QuadList)) + (define-predicate IdQuad? IdQuad) + (define id? IdQuad?) ;; version 3 ;; dummy kw arg is needed to typecheck correctly @@ -235,9 +232,6 @@ (make-quadattrs null)) xs)) - (define/typed (id? x) - (Any . -> . Boolean) - (and (quad? x) (equal? (quad-name x) 'id))) ))])) (define/typed (whitespace? x [nbsp? #f]) @@ -290,12 +284,12 @@ (: quad-has-attr? (Quad QuadAttrKey . -> . Boolean)) (define (quad-has-attr? q key) - (hash-has-key? (quad-attrs q) key)) + (and ((inst member QuadAttrKey) key (quad-attr-keys (quad-attrs q))) #t)) (define-quad-type box) - +#| (define-quad-type spacer) (define-quad-type kern) (define-quad-type optical-kern) @@ -317,3 +311,4 @@ (define-break-type column) (define-break-type block) (define-break-type line) +|# \ No newline at end of file