You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/quad/quads-typed.rkt

63 lines
2.4 KiB
Racket

10 years ago
#lang typed/racket/base
(require (for-syntax typed/racket/base racket/syntax))
;; struct implementation
(struct: quad ([name : Symbol] [attrs : (HashTable Symbol Any)] [list : (Listof quad)]) #:transparent
#:property prop:sequence (λ(q) (quad-list q)))
(define h (quad 'hello #hash((foo . bar)) (list (quad 'hello #hash((foo . bar)) '()))))
(define-syntax (define-box-type stx)
(syntax-case stx ()
[(_ id)
(with-syntax ([id? (format-id #'id "~a?" #'id)]
[ids? (format-id #'id "~as?" #'id)]
[lists-of-ids? (format-id #'id "list-of-~as?" #'id)]
[quads->id (format-id #'id "quads->~a" #'id)]
[inline/quads->id (format-id #'id "inline/quads->~a" #'id)])
#'(begin
;; quad predicate - ok to be relaxed here if we're strict when making the struct
(provide id?)
(: id? (Any . -> . Boolean))
(define (id? x)
(and (quad? x) (equal? (quad-name x) 'id)))
;; quad constructor
;; put contract here rather than on struct, because this is the main interface
;; and this contract is more liberal.
;; but don't put a separate contract on struct, because it's superfluous.
(define/contract (id [attrs #f] . xs)
(() ((or/c quad-attrs? hashable-list?)) #:rest quad-list? . ->* . id?)
(quad 'id (and attrs (if (hash? attrs) attrs (apply hash attrs))) xs))))]))
(define-box-type hello)
(define-box-type gbye)
#|
;; make this a macro because qs-in is often huge
;; and the macro avoids allocation + garbage collection
(define attr-missing (gensym))
(: gather-common-attrs ((Listof quad) . -> . (Listof CommonAttr)))
(define (gather-common-attrs qs)
(let loop : (Listof Commonattr)
([qs : (Listof quad) qs]
[common-attrs : (Listof Commonattr) (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)
empty)])
(cond
[(empty? common-attrs) #f]
[(empty? qs) (flatten common-attrs)]
[else (loop (cdr qs)
(filter (λ(ca) (equal? (quad-attr-ref (car qs) (car ca) attr-missing) (cdr ca)))
common-attrs))])))
|#