#lang plai-typed (require plai-typed/s-exp-match) (define-type Value [litV (n : string)] [closV (arg : symbol) (body : ExprC) (env : Env)]) (define-type ExprC [litC (n : string)] [idC (s : symbol)] [plusC (l : ExprC) (r : ExprC)] [multC (l : ExprC) (r : ExprC)] [lamC (n : symbol) (body : ExprC)] [appC (fun : ExprC) (arg : ExprC)]) (define-type Binding [bind (name : symbol) (val : Value)]) (define-type-alias Env (listof Binding)) (define mt-env empty) (define extend-env cons) (module+ test (print-only-errors true)) ;; parse ---------------------------------------- (define parse : (s-expression -> ExprC) (lambda (s) (cond [(s-exp-match? `STRING s) (litC (s-exp->string s))] [(s-exp-match? `SYMBOL s) (idC (s-exp->symbol s))] [(s-exp-match? '{+ ANY ANY} s) (plusC (parse (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? '{* ANY ANY} s) (multC (parse (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? '{let {[SYMBOL ANY]} ANY} s) (let ([bs (s-exp->list (first (s-exp->list (second (s-exp->list s)))))]) (appC (lamC (s-exp->symbol (first bs)) (parse (third (s-exp->list s)))) (parse (second bs))))] [(s-exp-match? '{lambda {SYMBOL} ANY} s) (lamC (s-exp->symbol (first (s-exp->list (second (s-exp->list s))))) (parse (third (s-exp->list s))))] [(s-exp-match? '{ANY ANY} s) (appC (parse (first (s-exp->list s))) (parse (second (s-exp->list s))))] [else (error 'parse "invalid input")]))) (define (parse/str [s : s-expression]) : ExprC (parse s)) (module+ test (test (parse/str '"a") (litC "a")) (test (parse/str `x) ; note: backquote instead of normal quote (idC 'x)) (test (parse/str '{+ "b" "a"}) (plusC (litC "b") (litC "a"))) (test (parse/str '{* "c" "d"}) (multC (litC "c") (litC "d"))) (test (parse/str '{+ {* "c" "d"} "e"}) (plusC (multC (litC "c") (litC "d")) (litC "e"))) (test (parse/str '{let {[x {+ "a" "b"}]} y}) (appC (lamC 'x (idC 'y)) (plusC (litC "a") (litC "b")))) (test (parse/str '{lambda {x} "g"}) (lamC 'x (litC "g"))) (test (parse/str '{double "g"}) (appC (idC 'double) (litC "g"))) (test/exn (parse/str '{{+ "a" "b"}}) "invalid input") (test/exn (parse/str '1) "invalid input")) ;; interp ---------------------------------------- (define interp : (ExprC Env -> Value) (lambda (a env) (type-case ExprC a [litC (n) (litV n)] [idC (s) (lookup s env)] [plusC (l r) (str+ (interp l env) (interp r env))] [multC (l r) (str* (interp l env) (interp r env))] [lamC (n body) (closV n body env)] [appC (fun arg) (type-case Value (interp fun env) [closV (n body c-env) (interp body (extend-env (bind n (interp arg env)) c-env))] [else (error 'interp "not a function")])]))) (define (interp/str [a : ExprC] [env : Env]) : Value (interp a env)) (module+ test (test (interp/str (parse/str '"b") mt-env) (litV "b")) (test/exn (interp/str (parse/str `x) mt-env) "free variable") (test (interp/str (parse/str `x) (extend-env (bind 'x (litV "g")) mt-env)) (litV "g")) (test (interp/str (parse/str '{+ "b" "a"}) mt-env) (litV "ba")) (test (interp/str (parse/str '{* "b" "a"}) mt-env) (litV "a")) (test (interp/str (parse/str '{+ {* "a" "b"} {+ "c" "d"}}) mt-env) (litV "bcd")) (test (interp/str (parse/str '{lambda {x} {+ x x}}) mt-env) (closV 'x (plusC (idC 'x) (idC 'x)) mt-env)) (test (interp/str (parse/str '{let {[x "e"]} {+ x x}}) mt-env) (litV "ee")) (test (interp/str (parse/str '{let {[x "e"]} {let {[x {+ "a" x}]} {+ x x}}}) mt-env) (litV "aeae")) (test (interp/str (parse/str '{let {[x "e"]} {let {[y "f"]} x}}) mt-env) (litV "e")) (test (interp/str (parse/str '{{lambda {x} {+ x x}} "f"}) mt-env) (litV "ff")) (test/exn (interp/str (parse/str '{"a" "b"}) mt-env) "not a function") (test/exn (interp/str (parse/str '{+ "a" {lambda {x} x}}) mt-env) "not a literal") (test/exn (interp/str (parse/str '{let {[bad {lambda {x} {+ x y}}]} {let {[y "e"]} {bad "b"}}}) mt-env) "free variable")) ;; str+ and str* ---------------------------------------- (define str-op : ((string string -> string) Value Value -> Value) (lambda (op l r) (cond [(and (litV? l) (litV? r)) (litV (op (litV-n l) (litV-n r)))] [else (error 'interp "not a literal")]))) (define (str+ [l : Value] [r : Value]) : Value (str-op string-append l r)) (define (str* [l : Value] [r : Value]) : Value (str-op string-mult l r)) (define (string-mult [a : string] [b : string]) (foldl (lambda (c r) (string-append b r)) "" (string->list a))) (module+ test (test (str+ (litV "abc") (litV "de")) (litV "abcde")) (test (str* (litV "abc") (litV "de")) (litV "dedede"))) ;; lookup ---------------------------------------- (define lookup : (symbol Env -> Value) (lambda (n env) (cond [(empty? env) (error 'lookup "free variable")] [else (cond [(symbol=? n (bind-name (first env))) (bind-val (first env))] [else (lookup n (rest env))])]))) (module+ test (test/exn (lookup 'x mt-env) "free variable") (test (lookup 'x (extend-env (bind 'x (litV "f")) mt-env)) (litV "f")) (test (lookup 'x (extend-env (bind 'x (litV "g")) (extend-env (bind 'x (litV "f")) mt-env))) (litV "g")) (test (lookup 'y (extend-env (bind 'x (litV "g")) (extend-env (bind 'y (litV "f")) mt-env))) (litV "f")))