only typecheck left
This commit is contained in:
parent
232bd43a7d
commit
e5b13e035a
@ -35,7 +35,6 @@
|
||||
[listT (element : Type)] ;; New
|
||||
[varT (id : Number) (val : (Boxof (Optionof Type)))])
|
||||
|
||||
|
||||
(define-type ValueEnv
|
||||
[EmptyValueEnv]
|
||||
[BindValue (name : Symbol)
|
||||
@ -68,6 +67,7 @@
|
||||
[(plusE l r) (num+ (interp l env) (interp r env))]
|
||||
[(minusE l r) (num- (interp l env) (interp r env))]
|
||||
[(timesE l r) (num* (interp l env) (interp r env))]
|
||||
[(listE elements) (listV (map (lambda (x) (interp x env)) elements))]
|
||||
[(idE name) (lookup name env)]
|
||||
[(if0E test then-part else-part)
|
||||
(if (numzero? (interp test env))
|
||||
@ -89,8 +89,13 @@
|
||||
(interp (closureV-body lam-val)
|
||||
(BindValue (closureV-param lam-val)
|
||||
arg-val
|
||||
(closureV-env lam-val))))]
|
||||
[(listE lst) (listV (map (lambda (x) (interp x env)) lst))])) ;; TODO COME BACK TO
|
||||
(closureV-env lam-val))))]))
|
||||
|
||||
(define (run s-expr)
|
||||
(interp (parse s-expr) (EmptyValueEnv)))
|
||||
|
||||
(define (check s-expr)
|
||||
(typecheck (parse s-expr) (EmptyTypeEnv)))
|
||||
|
||||
(define (lookup name env)
|
||||
(type-case ValueEnv env
|
||||
@ -120,6 +125,8 @@
|
||||
[(true) (boolE #t)]
|
||||
[(false) (boolE #f)]
|
||||
[else (idE sym)]))]
|
||||
[(s-exp-match? `(list ANY ...) sx)
|
||||
(listE (map (lambda (elt) (parse elt)) (rest (s-exp->list sx))))]
|
||||
[(s-exp-match? `(lam (SYMBOL : ANY) ANY) sx)
|
||||
(let* ([args (sx-ref sx 1)]
|
||||
[id (s-exp->symbol (sx-ref args 0))]
|
||||
@ -154,7 +161,9 @@
|
||||
[(bool) (boolTE)]
|
||||
[(?) (guessTE)])]
|
||||
[(s-exp-match? `(ANY -> ANY) sx)
|
||||
(arrowTE (parse-te (sx-ref sx 0)) (parse-te (sx-ref sx 2)))]))
|
||||
(arrowTE (parse-te (sx-ref sx 0)) (parse-te (sx-ref sx 2)))]
|
||||
[(s-exp-match? `(listof ANY) sx)
|
||||
(listTE (parse-te (sx-ref sx 1)))]))
|
||||
|
||||
(module+ test
|
||||
(define fact-rec
|
||||
@ -235,7 +244,7 @@
|
||||
[(arrowTE a b) (arrowT (parse-type a)
|
||||
(parse-type b))]
|
||||
[(guessTE)(varT (gen-tvar-id!) (box (none)))]
|
||||
[(listTE e) .... ]))
|
||||
[(listTE element-te) (listT (parse-type element-te))]))
|
||||
(define (type-lookup name-to-find env)
|
||||
(type-case TypeEnv env
|
||||
[(EmptyTypeEnv ) (error 'type-lookup "free variable, so no type")]
|
||||
@ -317,18 +326,24 @@
|
||||
[(varT id2 is2) (unify-type-var! t2 t1 expr)]
|
||||
[(numT) (unify-assert! t1 (numT) expr)]
|
||||
[(boolT) (unify-assert! t1 (boolT) expr)]
|
||||
[(listT element-type)
|
||||
(type-case Type t1
|
||||
[(listT other-element-type) (unify! element-type other-element-type expr)]
|
||||
[else (type-error expr t1 t2)])]
|
||||
[(arrowT a2 b2)
|
||||
(type-case Type t1
|
||||
[(arrowT a1 b1)
|
||||
(begin
|
||||
(unify! a1 a2 expr)
|
||||
(unify! b1 b2 expr))]
|
||||
[else (type-error expr t1 t2)])]
|
||||
[(listT a2)
|
||||
(type-case Type t1
|
||||
[(listT a1) (unify! a1 a2 expr)]
|
||||
[else (type-error expr t1 t2)])])]))
|
||||
|
||||
(module+ test
|
||||
(test (unify! (listT (boolT)) (listT (boolT)) 'test) (void))
|
||||
(test/exn (unify! (listT (boolT)) (listT (numT)) 'test) "no type")
|
||||
(test/exn (unify! (boolT) (listT (numT)) 'test) "no type")
|
||||
(test/exn (unify! (listT (numT)) (boolT) 'test) "no type"))
|
||||
|
||||
(define (typecheck [exp : Exp] [env : TypeEnv]) : Type
|
||||
(type-case Exp exp
|
||||
[(numE n) (numT)]
|
||||
@ -375,15 +390,12 @@
|
||||
(let* ([arg-type (parse-type te)]
|
||||
[res-type (typecheck body (BindType name arg-type env))])
|
||||
(arrowT arg-type res-type))]
|
||||
[(listE list) .... ]
|
||||
[(listE elements) (begin
|
||||
(define type-list (map (lambda (x) (typecheck x env)) elements))
|
||||
|
||||
(listT )]
|
||||
))
|
||||
|
||||
;; ----------------------------------------
|
||||
(define (run s-expr)
|
||||
(interp (parse s-expr) (EmptyValueEnv)))
|
||||
|
||||
(define (check s-expr)
|
||||
(typecheck (parse s-expr) (EmptyTypeEnv)))
|
||||
|
||||
(define-syntax-rule (test/type expr type)
|
||||
(test
|
||||
@ -422,6 +434,10 @@
|
||||
(numV 3))
|
||||
)
|
||||
|
||||
(module+ test
|
||||
(test (run `{list 1 2}) (listV (list (numV 1) (numV 2))))
|
||||
(test (run `{list false true false}) (listV (list (boolV #f) (boolV #t) (boolV #f)))))
|
||||
|
||||
(module+ test
|
||||
(print-only-errors #t)
|
||||
|
||||
@ -532,20 +548,6 @@
|
||||
#;(test/exn (typecheck (recE 'f (arrowTE (numTE) (numTE)) (idE 'f) (appE (idE 'f) (numE 10)))
|
||||
(EmptyTypeEnv))
|
||||
"no type"))
|
||||
|
||||
;; New list tests
|
||||
;; ------------------------------------
|
||||
|
||||
(module+ test
|
||||
(test (unify! (listT (boolT)) (listT (boolT)) 'test) (void))
|
||||
(test/exn (unify! (listT (boolT)) (listT (numT)) 'test) "no type")
|
||||
(test/exn (unify! (boolT) (listT (numT)) 'test) "no type")
|
||||
(test/exn (unify! (listT (numT)) (boolT) 'test) "no type"))
|
||||
|
||||
(module+ test
|
||||
(test (run `{list 1 2}) (listV (list (numV 1) (numV 2))))
|
||||
(test (run `{list false true false}) (listV (list (boolV #f) (boolV #t) (boolV #f)))))
|
||||
|
||||
(module+ test
|
||||
;; lists of numbers
|
||||
(test/type `{list 1 2} (listT (numT)))
|
||||
@ -572,3 +574,14 @@
|
||||
;; infer type of list from function application
|
||||
(test/type `{{lam {x : ?} {list x}} 2} (listT (numT)))
|
||||
)
|
||||
|
||||
(module+ test
|
||||
(test (unify! (listT (boolT)) (listT (boolT)) 'test) (void))
|
||||
(test/exn (unify! (listT (boolT)) (listT (numT)) 'test) "no type")
|
||||
(test/exn (unify! (boolT) (listT (numT)) 'test) "no type")
|
||||
(test/exn (unify! (listT (numT)) (boolT) 'test) "no type"))
|
||||
|
||||
(module+ test
|
||||
(test (run `{list 1 2}) (listV (list (numV 1) (numV 2))))
|
||||
(test (run `{list false true false}) (listV (list (boolV #f) (boolV #t) (boolV #f)))))
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user