#lang plaitypus (print-only-errors #t) (define-type Type [numberT] [arrowT (param : Type) (result : Type)] ;; NEW [boxT (contents-type : Type)]) (define-type TypeEnv [mtEnv] [aBind (name : symbol) (type : Type) (rest : TypeEnv)]) (define-type TBFAE [num (n : number)] [add (lhs : TBFAE) (rhs : TBFAE)] [sub (lhs : TBFAE) (rhs : TBFAE)] [id (name : symbol)] [fun (param-name : symbol) (param-type : Type) (body : TBFAE)] [app (fun-expr : TBFAE) (arg-expr : TBFAE)] ;; NEW [newbox (init-expr : TBFAE)] [setbox (box-expr : TBFAE) (new-value-expr : TBFAE)] [openbox (box-expr : TBFAE)] [seqn (expr1 : TBFAE) (expr2 : TBFAE)]) ;; ---------------------------------------------------------------------- ;; This is a monster. What have I done... (define parse : (s-expression -> TBFAE) (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)))] [(with) (check-pieces as-list "with" 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 `:`")) (app (fun (s-exp->symbol (first b-p)) (parse-type (third b-p)) (parse (third as-list))) (parse (fourth b-p)))] [(newbox) (check-pieces as-list "newbox" 2) (newbox (parse (second as-list)))] [(setbox) (check-pieces as-list "setbox" 3) (setbox (parse (second as-list)) (parse (third as-list)))] [(openbox) (check-pieces as-list "openbox" 2) (openbox (parse (second as-list)))] [(seqn) (check-pieces as-list "seqn" 3) (seqn (parse (second as-list)) (parse (third as-list)))] [else (parse-app as-list)])] [else (parse-app as-list)])] [else (error 'parse "wat")]))) (define parse-app : ((listof s-expression) -> TBFAE) (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)) (cond [(= (length as-list) 3) (unless (and (s-exp-symbol? (second as-list)) (equal? '-> (s-exp->symbol (second as-list)))) (error 'parse "expected `->`")) (arrowT (parse-type (first as-list)) (parse-type (third as-list)))] [(= (length as-list) 2) (unless (and (s-exp-symbol? (first as-list)) (equal? 'boxof (s-exp->symbol (first as-list)))) (error 'parse "expected `boxof`")) (boxT (parse-type (second as-list)))] [else (error 'parse "expected function of box type")])]))) (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 : (TBFAE TypeEnv -> Type) (lambda (a-tfae gamma) (type-case TBFAE 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)] [newbox (init-expr) (boxT (typecheck init-expr gamma))] [setbox (box-expr new-value-expr) (define box-type (typecheck box-expr gamma)) (unless (boxT? box-type) (error 'typecheck "expected box")) (define new-element-type (typecheck new-value-expr gamma)) (unless (equal? new-element-type (boxT-contents-type box-type)) (error 'typecheck "type mismatch")) new-element-type] [openbox (box-expr) (define box-type (typecheck box-expr gamma)) (unless (boxT? box-type) (error 'typecheck "expected box")) (boxT-contents-type box-type)] [seqn (expr1 expr2) (typecheck expr1 gamma) ; we don't need the type, but we need to make sure there are no errors! (typecheck expr2 gamma)]))) (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 `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") ;; ---------------------------------------------------------------------- (test (typecheck (parse `{with {b : (boxof number) {newbox 5}} {+ {openbox b} {openbox b}}}) (mtEnv)) (numberT)) (test (typecheck (parse `{with {b1 : (boxof number) {newbox 10}} {seqn {setbox b1 12} {seqn {setbox b1 14} {openbox b1}}}}) (mtEnv)) (numberT)) (test (typecheck (parse `{with {b1 : (boxof number) {newbox 19}} {with {b2 : (boxof number) {newbox 34}} {+ {openbox b1} {openbox b2}}}}) (mtEnv)) (numberT)) (test (typecheck (parse `{with {b1 : (boxof number) {newbox 19}} {with {b2 : (boxof number) {newbox 34}} {seqn {setbox b1 10} {+ {openbox b1} {openbox b2}}}}}) (mtEnv)) (numberT)) (test (typecheck (parse `{with {b1 : (boxof number) {newbox 19}} {with {b2 : (boxof number) {newbox 34}} {seqn {setbox b1 10} {seqn {setbox b2 6} {+ {openbox b1} {openbox b2}}}}}}) (mtEnv)) (numberT)) (test (typecheck (parse `{newbox 10}) (mtEnv)) (boxT (numberT))) (test (typecheck (parse `{openbox {newbox 10}}) (mtEnv)) (numberT)) (test (typecheck (parse `{openbox {openbox {newbox {newbox 10}}}}) (mtEnv)) (numberT)) (test (typecheck (parse `{seqn {openbox {newbox 10}} 3}) (mtEnv)) (numberT)) (test (typecheck (parse `{with {b : (boxof number) {newbox 0}} {seqn {setbox b 10} {openbox b}}}) (mtEnv)) (numberT)) (test (typecheck (parse `{with {b : (boxof number) {newbox 0}} {seqn {setbox b 10} {seqn {setbox b 12} {openbox b}}}}) (mtEnv)) (numberT)) (test/exn (typecheck (parse `{newbox {+ 2 {newbox 5}}}) (mtEnv)) "expected number") (test/exn (typecheck (parse `{openbox 3}) (mtEnv)) "expected box") (test/exn (typecheck (parse `{setbox 3 5}) (mtEnv)) "expected box") (test/exn (typecheck (parse `{openbox {fun {x : number} x}}) (mtEnv)) "expected box") (test/exn (typecheck (parse `{setbox {fun {x : number} x} 5}) (mtEnv)) "expected box")