#lang plait ;; ============================================================================= ;; Type Checker (Fall 2020): support.rkt ;; ============================================================================= ;; DO NOT EDIT THIS FILE ======================================================= (define-type-alias TEnv (Hashof Symbol Type)) (define-type Type (t-num) (t-bool) (t-str) (t-fun [arg-type : Type] [return-type : Type]) (t-list [elem-type : Type])) (define-type Expr (e-num [x : Number]) (e-bool [x : Boolean]) (e-str [x : String]) (e-op [op : Operator] [left : Expr] [right : Expr]) (e-un-op [op : UnaryOperator] [expr : Expr]) (e-if [cond : Expr] [consq : Expr] [altern : Expr]) (e-lam [param : Symbol] [arg-type : Type] [body : Expr]) (e-app [func : Expr] [arg : Expr]) (e-id [name : Symbol]) (e-let [id : Symbol] [value : Expr] [body : Expr]) (e-empty [elem-type : Type])) (define-type Operator (op-plus) (op-append) (op-num-eq) (op-str-eq) (op-link)) (define-type UnaryOperator (op-first) (op-rest) (op-is-empty)) (define-type TypeCheckingError (tc-err-if-got-non-boolean [cond-type : Type]) (tc-err-bad-arg-to-op [op : Operator] [arg-type : Type]) (tc-err-bad-arg-to-un-op [op : UnaryOperator] [arg-type : Type]) (tc-err-unbound-id [name : Symbol]) (tc-err-not-a-function [func-type : Type]) (tc-err-bad-arg-to-fun [func-type : Type] [arg-type : Type]) (tc-err-if-branches [then-type : Type] [else-type : Type])) (define-syntax-rule (~a arg ...) (foldl (lambda (val string) (string-append string val)) "" (list (to-string arg) ...))) (define (type-checking-error->string type-checking-error) (type-case TypeCheckingError type-checking-error [(tc-err-if-got-non-boolean cond-type) (~a "if got non boolean value " cond-type)] [(tc-err-bad-arg-to-op op arg-type) (~a "operator " op " got bad arg " arg-type)] [(tc-err-bad-arg-to-un-op op arg-type) (~a "operator " op " got bad arg " arg-type)] [(tc-err-unbound-id name) (~a name " is unbound")] [(tc-err-not-a-function val) (~a val " is not a function")] [(tc-err-bad-arg-to-fun func-type arg-type) (~a "function type " func-type " and arg type " arg-type " do not match")] [(tc-err-if-branches then-type else-type) (~a "if statement branches with " then-type " and " else-type)])) (define (raise-error [err : TypeCheckingError]) (error 'TypeCheckingError (type-checking-error->string err))) (define (parse [input : S-Exp]): Expr (cond [(s-exp-match? `true input) (e-bool #t)] [(s-exp-match? `false input) (e-bool #f)] [(s-exp-string? input) (e-str (s-exp->string input))] [(s-exp-number? input) (e-num (s-exp->number input))] [(s-exp-match? `{if ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 4) (e-if (parse (second inlst)) (parse (third inlst)) (parse (fourth inlst))) (error 'if "incorrect number of args to if")))] [(s-exp-match? `{+ ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 3) (e-op (op-plus) (parse (second inlst)) (parse (third inlst))) (error '+ "incorrect number of args to +")))] [(s-exp-match? `{++ ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 3) (e-op (op-append) (parse (second inlst)) (parse (third inlst))) (error '++ "incorrect number of args to ++")))] [(s-exp-match? `{num= ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 3) (e-op (op-num-eq) (parse (second inlst)) (parse (third inlst))) (error 'num= "incorrect number of args to num=")))] [(s-exp-match? `{str= ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 3) (e-op (op-str-eq) (parse (second inlst)) (parse (third inlst))) (error 'str= "incorrect number of args to str=")))] [(s-exp-match? `{lam {SYMBOL : ANY} ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 3) (e-lam (s-exp->symbol (first (s-exp->list (second inlst)))) (parse-type (third (s-exp->list (second inlst)))) (parse (third inlst))) (error 'lam "lambdas should only have one body")))] [(s-exp-match? `{lam {SYMBOL : ANY ...} ANY ...} input) (error 'lam "lambdas must have exactly one parameter")] [(s-exp-match? `{let {SYMBOL ANY} ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 3) (e-let (s-exp->symbol (first (s-exp->list (second inlst)))) (parse (second (s-exp->list (second inlst)))) (parse (third inlst))) (error 'let "incorrect number of args to let")))] [(s-exp-match? `{let {SYMBOL ANY ...} ANY ...} input) (error 'let "let statements require a type annotation")] [(s-exp-match? `{empty : ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 3) (e-empty (parse-type (third inlst))) (error 'empty "incorrect number of args to empty")))] [(s-exp-match? `{link ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 3) (e-op (op-link) (parse (second inlst)) (parse (third inlst))) (error 'link "incorrect number of args to link")))] [(s-exp-match? `{is-empty ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 2) (e-un-op (op-is-empty) (parse (second inlst))) (error 'is-empty "incorrect number of args to is-empty")))] [(s-exp-match? `{first ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 2) (e-un-op (op-first) (parse (second inlst))) (error 'first "incorrect number of args to first")))] [(s-exp-match? `{rest ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 2) (e-un-op (op-rest) (parse (second inlst))) (error 'rest "incorrect number of args to rest")))] [(s-exp-match? `{ANY ...} input) (let ([inlst (s-exp->list input)]) (if (equal? (length inlst) 2) (e-app (parse (first inlst)) (parse (second inlst))) (error 'app "incorrect number of args to app")))] [(s-exp-symbol? input) (e-id (s-exp->symbol input))])) (define (parse-type [t : S-Exp]): Type (cond [(s-exp-match? `Num t) (t-num)] [(s-exp-match? `Bool t) (t-bool)] [(s-exp-match? `Str t) (t-str)] [(s-exp-match? `{ANY -> ANY} t) (t-fun (parse-type (first (s-exp->list t))) (parse-type (third (s-exp->list t))))] [(s-exp-match? `{List ANY} t) (t-list (parse-type (second (s-exp->list t))))] [else (error 'type "invalid type annotation")]))