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.
63 lines
2.4 KiB
Racket
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))])))
|
||
|
|
|#
|
||
|
|
|