(define (check-match switch-type x)
(let ([pattern (car x)]
[expr (cadr x)])
- (if (eqv? (ast-type pattern) 'app)
+ (case (ast-type pattern)
+ ['app
; a pattern match with bindings
(let ([sum (assoc (car pattern) (cdr (assoc switch-type dls)))])
(unless sum (error #f "can't pattern match ~a with ~a" switch-type pattern))
(let* ([names (cdr pattern)]
[types (cdr sum)]
[new-env (fold-left env-insert env names types)])
- (check dls new-env expr)))
+ (check dls new-env expr)))]
+ ; pattern match with binding and no constructor
+ ['var (check dls (env-insert env pattern switch-type) expr)]
; a pattern match without bindings
- (check dls env expr))))
+ [else (check dls env expr)])))
(let* ([switch-type-res (check dls env (case-switch x))]
[switch-type (cadr switch-type-res)]
[resolved-type (substitute case-expr-equality-cs (car case-expr-types))]
- [annotated `((case (,(case-expr x) : ,switch-type)
- ,(map (lambda (c e et)
- `(,c (,e : ,et)))
+ [annotated `((case ,(caddr switch-type-res)
+ ,@(map (lambda (c e et)
+ `(,c ((,e : ,et))))
(map car (case-cases x))
(map cadr (case-cases x))
case-expr-types)) : ,resolved-type)]
`((let ,(map (lambda (o n) (list (car o) (denormalize (cadr o) (cadr n))))
(let-bindings orig)
(let-bindings (ann-expr normed)))
- ,@(map (lambda (o n) (denormalize o n))
+ ,@(map denormalize
(let-body orig)
(let-body (ann-expr normed)))) : ,(ann-type normed))]
['if `((if ,@(map denormalize (cdr orig) (cdr (ann-expr normed))))
- : (ann-type normed))]
+ : ,(ann-type normed))]
+ ['case `((case ,(denormalize (case-switch orig) (case-switch (ann-expr normed)))
+ ,@(map (lambda (o n) (cons (car o) (denormalize (cadr o) (cadr n))))
+ (case-cases orig) (case-cases (ann-expr normed))))
+ : ,(ann-type normed))]
[else normed]))
(define ann-expr car)
(define (annotate-types prog)
(denormalize
(program-body prog)
- (caddr (check (init-adts-env prog) (normalize (program-body prog))))))
+ (caddr (check (program-data-layouts prog)
+ (init-adts-env prog)
+ (normalize (program-body prog))))))
; returns a list of constraints