+ [annotated `((,(caddr func-type-res)
+ ,(caddr arg-type-res)) : ,resolved-return-type)])
+
+ (if (abs? resolved-func-type)
+ (let ((return-type (substitute cs (caddr resolved-func-type))))
+ (list cs return-type annotated))
+ (error #f "not a function"))))
+
+(define (check-case dls env x)
+
+ (define (check-match switch-type x)
+
+ (define (get-bindings product-types pattern)
+ (define (go product-type product)
+ (case (ast-type product)
+ ['var (list (cons product product-type))]
+ ; an inner pattern match
+ ['app (let* ([inner-sum (car product)]
+ [inner-sums (cdr (assoc product-type dls))]
+ [inner-product-types (cdr (assoc inner-sum inner-sums))])
+ (get-bindings inner-product-types product))]
+ [else '()]))
+ (flat-map go product-types (cdr pattern)))
+
+
+ (let ([pattern (car x)]
+ [expr (cadr x)])
+ (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)]
+ [product-types (cdr sum)]
+ [new-env (append (get-bindings product-types pattern) env)])
+
+ (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
+ [else (check dls env expr)])))
+
+ (let* ([switch-type-res (check dls env (case-switch x))]
+ [switch-type (cadr switch-type-res)]
+
+ [case-expr-type-res (map (lambda (x) (check-match switch-type x)) (case-cases x))]
+ [case-expr-types (map cadr case-expr-type-res)]
+
+ [case-expr-equality-cs (fold-left constraint-merge '()
+ (map (lambda (t) (~ t (car case-expr-types)))
+ (cdr case-expr-types)))]
+
+ [resolved-type (substitute case-expr-equality-cs (car case-expr-types))]
+
+ [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)]
+
+ [cs (fold-left constraint-merge '()
+ (cons (car switch-type-res) case-expr-equality-cs))])
+ (list cs resolved-type annotated)))
+
+; returns a list (constraints type annotated)
+(define (check dls env x)
+ (define (make-result cs type)
+ (list cs type `(,x : ,type)))