logn-id.rkt (3167B)
1 #lang typed/racket 2 (require "typed-untyped.rkt") 3 (define-typed/untyped-modules #:no-test 4 (provide define-logn-ids) 5 6 (require (for-syntax syntax/parse 7 racket/syntax 8 racket/function 9 racket/match 10 syntax/stx) 11 "typed-untyped.rkt") 12 13 (begin-for-syntax 14 (define (insert make-node v ts) 15 (match ts 16 [`() `((,v))] 17 [`(() . ,b) `((,v) . ,b)] 18 [`((,a) . ,b) `(() . ,(insert make-node (make-node v a) b))])) 19 20 (define (merge-trees make-node ts) 21 (match ts 22 [`{[,a]} a] 23 [`{[,a] [] . ,rest} (merge-trees make-node `{[,a] . ,rest})] 24 [`{[] . ,rest} (merge-trees make-node rest)] 25 [`{[,a] [,b] . ,rest} (merge-trees make-node 26 `{[,(make-node a b)] . ,rest})])) 27 28 (define (make-binary-tree l make-node make-leaf) 29 (merge-trees make-node 30 (foldl (curry insert make-node) 31 '() 32 (map make-leaf l))))) 33 34 (define-syntax (define-logn-ids stx) 35 (syntax-parse stx 36 [(_ matcher:id [id:id ty:id] ...) 37 (define/with-syntax (tmp ...) (generate-temporaries #'(id ...))) 38 (define bt 39 (make-binary-tree (syntax->list #'([ty id . tmp] ...)) 40 (λ (x y) `(node ,(generate-temporary) ,x ,y)) 41 (λ (x) `(leaf ,(stx-car x) 42 ,(generate-temporary (stx-car x)) 43 ,(stx-car (stx-cdr x)) 44 ,(stx-cdr (stx-cdr x)))))) 45 (define (make-structs bt parent) 46 (match bt 47 [`(node ,s ,a ,b) #`(begin (struct #,s #,@parent ()) 48 #,(make-structs a (list s)) 49 #,(make-structs b (list s)))] 50 [`(leaf ,t ,s ,a ,_) #`(begin (struct #,s #,@parent 51 () 52 #:type-name #,t) 53 (define #,a (#,s)))])) 54 (define (make-btd bt) 55 (match bt 56 [`(node ,s ,(and a `(,_ ,sa . ,_)) ,b) 57 #`(if (if-typed ((make-predicate #,sa) v-cache) 58 #,(format-id sa "~a?" sa)) 59 #,(make-btd a) 60 #,(make-btd b))] 61 [`(leaf ,s ,a ,t ,tmp) 62 tmp])) 63 #`(begin #,(make-structs bt #'()) 64 (define-syntax (matcher stx) 65 (syntax-parse stx 66 [(_ v:expr [(~literal id) tmp] ...) 67 #'(let ([v-cache v]) 68 #,(make-btd bt))])))])) 69 70 (module* test typed/racket 71 (require (submod "..") 72 typed/rackunit) 73 74 (define-logn-ids match-x [a A] [b B] [c C] [d D] [e E]) 75 76 (check-equal? (match-x (ann b (U A B C D E)) 77 [a 1] 78 [b 2] 79 [c 3] 80 [d 4] 81 [e 5]) 82 2)))