#lang plaitypus (print-only-errors #t) (define-type Type [numberT] [arrowT (param : Type) (result : Type)]) (define-type TypeEnv [mtEnv] [aBind (name : symbol) (type : Type) (rest : TypeEnv)]) (define-type TRCFAE [num (n : number)] [add (lhs : TRCFAE) (rhs : TRCFAE)] [sub (lhs : TRCFAE) (rhs : TRCFAE)] [id (name : symbol)] [fun (param-name : symbol) (param-type : Type) (body : TRCFAE)] [app (fun-expr : TRCFAE) (arg-expr : TRCFAE)] ;; NEW [if0 (test-expr : TRCFAE) (then-expr : TRCFAE) (else-expr : TRCFAE)] [rec (name : symbol) (type : Type) (named-expr : TRCFAE) (body : TRCFAE)]) ;; ---------------------------------------------------------------------- ;; This is a monster. What have I done... (define parse : (s-expression -> TRCFAE) (lambda (s-exp) (cond [(s-exp-number? s-exp) (num (s-exp->number s-exp))] [(s-exp-symbol? s-exp) (id (s-exp->symbol s-exp))] [(s-exp-list? s-exp) (define as-list (s-exp->list s-exp)) (cond [(empty? as-list) (error 'parse "the empty list is not a valid FAE")] [(s-exp-symbol? (first as-list)) (case (s-exp->symbol (first as-list)) [(+) (check-pieces as-list "add" 3) (add (parse (second as-list)) (parse (third as-list)))] [(-) (check-pieces as-list "sub" 3) (sub (parse (second as-list)) (parse (third as-list)))] [(fun) (check-pieces as-list "fun" 3) (unless (s-exp-list? (second as-list)) (error 'parse "expected parameter list")) (define param-list (s-exp->list (second as-list))) (check-pieces param-list "parameter list" 3) (unless (s-exp-symbol? (first param-list)) (error 'parse "expected symbol as parameter name")) (unless (and (s-exp-symbol? (second param-list)) (equal? ': (s-exp->symbol (second param-list)))) (error 'parse "expected `:`")) (fun (s-exp->symbol (first param-list)) (parse-type (third param-list)) (parse (third as-list)))] [(if0) (check-pieces as-list "if0" 4) (if0 (parse (second as-list)) (parse (third as-list)) (parse (fourth as-list)))] [(rec) (check-pieces as-list "rec" 3) (unless (s-exp-list? (second as-list)) (error 'parse "expected binding pair")) (define b-p (s-exp->list (second as-list))) (check-pieces b-p "binding pair" 4) (unless (s-exp-symbol? (first b-p)) (error 'parse "expected symbol as variable name")) (unless (and (s-exp-symbol? (second b-p)) (equal? ': (s-exp->symbol (second b-p)))) (error 'parse "expected `:`")) (rec (s-exp->symbol (first b-p)) (parse-type (third b-p)) (parse (fourth b-p)) (parse (third as-list)))] [else (parse-app as-list)])] [else (parse-app as-list)])] [else (error 'parse "wat")]))) (define parse-app : ((listof s-expression) -> TRCFAE) (lambda (s-exps) (check-pieces s-exps "app" 2) (app (parse (first s-exps)) (parse (second s-exps))))) (define parse-type : (s-expression -> Type) (lambda (s-exp) (cond [(and (s-exp-symbol? s-exp) (equal? 'number (s-exp->symbol s-exp))) (numberT)] [(s-exp-list? s-exp) (define as-list (s-exp->list s-exp)) (check-pieces as-list "function type" 3) (cond [(and (s-exp-symbol? (second as-list)) (equal? '-> (s-exp->symbol (second as-list)))) (arrowT (parse-type (first as-list)) (parse-type (third as-list)))] [else (error 'parse "expected `->`")])]))) (define check-pieces : ((listof s-expression) string number -> void) (lambda (s-exps expected n-pieces) (unless (= n-pieces (length s-exps)) (error 'parse (string-append (string-append "expected " expected) (string-append " got " (to-string s-exps))))))) ;; ---------------------------------------------------------------------- (define typecheck : (TRCFAE TypeEnv -> Type) (lambda (a-tfae gamma) (type-case TRCFAE a-tfae [num (n) (numberT)] [add (l r) (define l-ty : Type (typecheck l gamma)) (define r-ty : Type (typecheck r gamma)) (unless (equal? l-ty (numberT)) (error 'typecheck "expected number")) (unless (equal? r-ty (numberT)) (error 'typecheck "expected number")) (numberT)] [sub (l r) (define l-ty : Type (typecheck l gamma)) (define r-ty : Type (typecheck r gamma)) (unless (equal? l-ty (numberT)) (error 'typecheck "expected number")) (unless (equal? r-ty (numberT)) (error 'typecheck "expected number")) (numberT)] [id (name) (get-type name gamma)] [fun (param-name param-type body) (arrowT param-type (typecheck body (aBind param-name param-type gamma)))] [app (fun-expr arg-expr) (define fun-type : Type (typecheck fun-expr gamma)) (define arg-type : Type (typecheck arg-expr gamma)) (unless (arrowT? fun-type) (error 'typecheck "expected function")) (unless (equal? arg-type (arrowT-param fun-type)) (error 'typecheck "type mismatch")) (arrowT-result fun-type)] [if0 (test-expr then-expr else-expr) (unless (equal? (typecheck test-expr gamma) (numberT)) (error 'typecheck "expected number")) (define then-type (typecheck then-expr gamma)) (define else-type (typecheck else-expr gamma)) (unless (equal? then-type else-type) (error 'typecheck "type mismatch")) then-type] [rec (name type named-expr body) (define new-gamma (aBind name type gamma)) (define named-type (typecheck named-expr new-gamma)) (define body-type (typecheck body new-gamma)) (unless (equal? named-type type) (error 'typecheck "type mismatch")) body-type]))) (define get-type : (symbol TypeEnv -> Type) (lambda (name gamma) (type-case TypeEnv gamma [mtEnv () (error 'typecheck "free identifier")] [aBind (name2 type rest) (if (equal? name name2) type (get-type name rest))]))) (test (typecheck (parse `{rec {sad-fac : (number -> number) {fun {x : number} {if0 x 0 {sad-fac {- x 1}}}}} {sad-fac 5}}) (mtEnv)) (numberT)) (test (typecheck (parse `{rec {inf : (number -> (number -> number)) {fun {x : number} {inf x}}} {inf 0}}) (mtEnv)) (arrowT (numberT) (numberT))) (test (typecheck (parse `{rec {x : (number -> number) x} x}) (mtEnv)) (arrowT (numberT) (numberT))) ;; ---------------------------------------------------------------------- (test (typecheck (parse `5) (mtEnv)) (numberT)) (test/exn (typecheck (parse `x) (mtEnv)) "free identifier") (test (typecheck (parse `{+ 2 3}) (mtEnv)) (numberT)) (test (typecheck (parse `{- 2 3}) (mtEnv)) (numberT)) (test (typecheck (parse `{fun {x : number} {+ x 5}}) (mtEnv)) (arrowT (numberT) (numberT))) (test/exn (typecheck (parse `{5 3}) (mtEnv)) "expected function") (test/exn (typecheck (parse `{fun {x : number} {x 5}}) (mtEnv)) "expected function") (test/exn (typecheck (parse `{+ 3 {fun {x : number} {+ x 5}}}) (mtEnv)) "expected number") (test (typecheck (parse `{{fun {x : number} {+ x 5}} 3}) (mtEnv)) (numberT)) (test (typecheck (parse `{fun {f : (number -> number)} {f 5}}) (mtEnv)) ;(arrowT (arrowT (numberT) ; (numberT)) ; (numberT)) (parse-type `((number -> number) -> number))) (test (typecheck (parse `{fun {f : (number -> number)} {fun {x : number} {f x}}}) (mtEnv)) (parse-type `((number -> number) -> (number -> number)))) (test/exn (typecheck (parse `{{fun {f : (number -> number)} {fun {x : number} {f x}}} 5}) (mtEnv)) "type mismatch") (test (typecheck (parse `{{fun {f : (number -> number)} {fun {x : number} {f x}}} {fun {y : number} {+ y 5}}}) (mtEnv)) (parse-type `(number -> number))) ;; ---------------------------------------------------------------------- (test (typecheck (parse `5) (mtEnv)) (numberT)) (test (typecheck (parse `{+ 2 3}) (mtEnv)) (numberT)) (test (typecheck (parse `{fun {x : number} {+ x 5}}) (mtEnv)) (arrowT (numberT) (numberT))) (test (typecheck (parse `{fun {f : (number -> number)} {fun {x : number} {f x}}}) (mtEnv)) ;(arrowT (arrowT (numberT) (numberT)) ; (arrowT (numberT) (numberT))) (parse-type `((number -> number) -> (number -> number)))) (test/exn (typecheck (parse `{{fun {f : (number -> number)} {fun {x : number} {f x}}} 3}) (mtEnv)) "type mismatch") (test (typecheck (parse `{{fun {f : (number -> number)} {fun {x : number} {f x}}} {fun {x : number} {+ x 5}}}) (mtEnv)) (parse-type `(number -> number))) (test (typecheck (parse `{{{fun {f : (number -> number)} {fun {x : number} {f x}}} {fun {x : number} {+ x 5}}} 5}) (mtEnv)) (numberT)) (test (typecheck (parse `5) (mtEnv)) (numberT)) (test (typecheck (parse `{+ 4 5}) (mtEnv)) (numberT)) (test (typecheck (parse `{- 4 5}) (mtEnv)) (numberT)) (test/exn (typecheck (parse `{+ 4 {fun {x : number} x}}) (mtEnv)) "expected number") (test (typecheck (parse `{fun {x : number} x}) (mtEnv)) (parse-type `(number -> number))) (test (typecheck (parse `{fun {x : number} {+ x 5}}) (mtEnv)) (parse-type `(number -> number))) (test (typecheck (parse `{fun {f : (number -> number)} {f 5}}) (mtEnv)) (parse-type `((number -> number) -> number))) (test (typecheck (parse `{{fun {x : number} x} 5}) (mtEnv)) (numberT)) (test (typecheck (parse `{{fun {f : (number -> number)} {f 5}} {fun {x : number} x}}) (mtEnv)) (numberT)) (test/exn (typecheck (parse `{4 5}) (mtEnv)) "expected function") (test/exn (typecheck (parse `{{fun {f : (number -> number)} {f 5}} 4}) (mtEnv)) "type mismatch")