#lang plai-typed (require plai-typed/s-exp-match) (print-only-errors true) ;; represents an expression in the Excr language (define-type ExcrC (appendC [l : ExcrC] [r : ExcrC]) (strC [s : string]) (callC [name : symbol] [arg : ExcrC]) (idC [name : symbol])) (define-type Fundef (fundefC [name : symbol] [argument : symbol] [body : ExcrC])) ;; example of calling plural function '{plural ++++ "chair"} ;; represented as AST (callC 'plural (strC "chair")) ;; concrete stx examples #;'"abc" #;'{"abc" + {"def" + "magnificent!!"}} '{"a" + "b" + "c"} '{"abc" + {"d" + "efg"} + "abr"} ;; example of fundef '{plural ---- word {word + "s"}} ;; represented as AST (fundefC 'plural 'word (appendC (idC 'word) (strC "s"))) ;; examples #;(strC "abc") #;(appendC (strC "abc") (appendC (strC "def") (strC "magnificent!!"))) (appendC (appendC (strC "a") (strC "b") ) (strC "c")) (require (typed-in racket [fifth : ((listof 'a) -> 'a)])) ;; parse an s-exp into an ExcrC (define (parse [s : s-expression]) : ExcrC (cond [(s-exp-string? s) (strC (s-exp->string s))] [(s-exp-match? `{ANY + ANY} s) (appendC (parse (first (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? `{ANY + ANY + ANY} s) #;(let ([sl (s-exp->list s)]) (parse `{{,(first sl) + ,(third sl)} + ,(fifth sl)})) (appendC (appendC (parse (first (s-exp->list s))) (parse (third (s-exp->list s)))) (parse (fifth (s-exp->list s))))] [else (error 'parse (string-append "not an excrC: " (to-string s)))]) ) ;; parse an s-exp into a FundefC (define (parse-fundef [s : s-expression]) : Fundef (fundefC 'foo 'bar (strC "baz"))) (test (parse '"abc") (strC "abc")) (test (parse '["abc" + {"def" + "magnificent!!"}]) (appendC (strC "abc") (appendC (strC "def") (strC "magnificent!!")))) (test/exn (parse '{"foo " + {"abc" "not a bplus" "too many" "elemnets"}}) "not a") #;(parse '{"foo " + {"abc" "not a bplus" "too many" "elemnets"}}) (test (parse '{"a" + "b" + "c"}) (appendC (appendC (strC "a") (strC "b") ) (strC "c"))) (define my-hash (hash (list))) (hash-set (hash-set my-hash 'p 143) 'q 239874) ;; EVALUATOR ;; an environment is represented as a list of bindings (define-type-alias Env (listof Binding)) ;; a binding represents a binding (define-type Binding [bind (name : symbol) (val : string)] ) ;; evaluates an ExcrC (define (eval [e : ExcrC] [env : Env] [funs : (listof Fundef)]) : string (type-case ExcrC e [idC (x) (env-lookup x env)] [strC (s) s] [appendC (l r) (string-append (eval l env funs) (eval r env funs))] [callC (f a) (let ([defn (find-function funs f)]) (type-case Fundef defn [fundefC (name param body) (eval body (add-binding param (eval a env funs) empty) funs)]))])) ;; add a binding to an env (define (add-binding [from : symbol] [to : string] [ontopof : Env]) (cons (bind from to) ontopof)) (test (add-binding 'z "134" empty) (list (bind 'z "134"))) (test (add-binding 'xxx "wheee!" (list (bind 'z "134"))) (list (bind 'xxx "wheee!") (bind 'z "134"))) ;; look up a binding in an env (define (env-lookup [name : symbol] [env : Env]) : string (cond [(empty? env) (error 'env-lookup (string-append "no binding for: " (to-string name)))] [else (cond [(eq? name (bind-name (first env))) (bind-val (first env))] [else (env-lookup name (rest env))])])) (test (env-lookup 'z (list (bind 'xxx "wheee!") (bind 'z "134"))) "134") ;; find a function (UNTESTED) (define (find-function lof name) (cond [(empty? lof) (error 'find-function "oenuthaonetuhnt")] [else (cond [(eq? name (fundefC-name (first lof))) (first lof)] [else (find-function (rest lof) name)])])) ;; perform substitution (UNTESTED) (define (subst param val exp) : ExcrC (type-case ExcrC exp [idC (x) (cond [(eq? x param) (strC val)] [else exp])] [strC (s) exp] [appendC (l r) (appendC (subst param val l) (subst param val r))] [callC (f a) (callC f (subst param val a))])) (test (eval (strC "abc") empty empty) "abc") (test (eval (appendC (strC "abc") (appendC (strC "def") (strC "magnificent!!"))) empty empty) "abcdefmagnificent!!") (define MY-FUNS (list (parse-fundef '{plural ---- word {word + "s"}}))) (define MY-PARSED-FUNS (list (fundefC 'plural 'zzzzygba (appendC (idC 'word) (strC "s"))) (fundefC 'sillyfun 'word (callC 'plural (idC 'word))))) #;(test (eval (parse '{plural ++++ "cat"}) MY-FUNS) "cats") (test/exn (eval (callC 'sillyfun (strC "cat")) empty MY-PARSED-FUNS) "no binding for") #;(test (eval (callC 'plural (strC "cat")) empty MY-PARSED-FUNS) "cats") #;(test (prog-eval '{{plural ---- word {word + "s"}} {main ---- argv {plural ++++ "cat"}}}) "cats") #;(;; AFTERNOON: (print-only-errors true) (require plai-typed/s-exp-match) ;ExcrC ::= string ; | { $ ExcrC ExcrC } ; | { $ ExcrC ExcrC ExcrC } '"horse" '{$ {$ "cat" "bird"} "elephant"} '{$ "1" "01" "100"} ;; should evaluate to "100" ;; example of function definition '{whatis banaLong b {$ b "banana"}} ;; example of calling banaLong: '{banaLong "mountain lion"} (define-type ExcrC2 [strC (s : string)] [longerC (l : ExcrC2) (r : ExcrC2)] [idC (x : symbol)] [appC (f : symbol) (argument : ExcrC2)]) (define-type Fundef [fundefC [name : symbol] [param : symbol] [body : ExcrC2]]) (strC "horse") (longerC (longerC (strC "cat") (strC "bird")) (strC "elephant")) (longerC (strC "1") (longerC (strC "01") (strC "100"))) (fundefC 'banaLong 'b (longerC (idC 'b) (strC "banana"))) (appC 'banaLong (strC "mountain lion")) ; parse an s-expression into an ExcrC (define (parse [s : s-expression]) : ExcrC2 (cond [(s-exp-string? s) (strC (s-exp->string s))] [(s-exp-match? `{$ ANY ANY} s) (longerC (parse (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? `{$ ANY ANY ANY} s) (expand-triple-longer (s-exp->list s))] [else (error 'parse (string-append "expected legal ExprC, got: " (to-string s)))])) ;; expand a triple-longer into nested longers (define (expand-triple-longer parts) : ExcrC2 (parse (list->s-exp (list `$ (second parts) (list->s-exp (list `$ (third parts) (fourth parts))))))) (test (expand-triple-longer (list `$ `"a" `"b" `"c")) (longerC (strC "a") (longerC (strC "b") (strC "c")))) (test (parse '"horse") (strC "horse")) (test (parse '{$ {$ "cat" "bird"} "elephant"}) (longerC (longerC (strC "cat") (strC "bird")) (strC "elephant"))) #;(test/exn (parse '{$ {$ "cat" "bird" "dogf"} "elephant"}) "expected legal ExprC") #;(parse '{$ {$ "cat" "bird" "dogf"} "elephant"}) (test (parse '{$ "1" "01" "100"}) (longerC (strC "1") (longerC (strC "01") (strC "100")))) ;; an environment is represented as a list of bindings (define-type-alias Env (listof Binding)) ;; a binding represents a binding (define-type Binding [bind (name : symbol) (val : string)]) ;; add a binding to an env (define (add-binding from to ontopof) (cons (bind from to) ontopof)) (test (add-binding 'z "134" empty) (list (bind 'z "134"))) (test (add-binding 'xxx "wheee!" (list (bind 'z "134"))) (list (bind 'xxx "wheee!") (bind 'z "134"))) ;; look up a binding in an env (define (env-lookup [name : symbol] [env : Env]) : string (cond [(empty? env) (error 'env-lookup (string-append "no binding for: " (to-string name)))] [else (cond [(eq? name (bind-name (first env))) (bind-val (first env))] [else (env-lookup name (rest env))])])) (test (env-lookup 'z (list (bind 'xxx "wheee!") (bind 'z "134"))) "134") ;; evaluate an ExcrC (define (eval [e : ExcrC2] [env : Env] [fundefs : (listof Fundef)]) : string (type-case ExcrC2 e [idC (x) (env-lookup x env)] [strC (s) s] [longerC (l r) (longer (eval l env fundefs) (eval r env fundefs))] [appC (f a) (let ([def (lookup f fundefs)]) (type-case Fundef def [fundefC (n p body) (eval body (add-binding p (eval a env fundefs) empty) fundefs)]))])) ;; find a function (UNTESTED) (define (lookup [name : symbol] lof) (cond [(empty? lof) (error 'find-function "oenuthaonetuhnt")] [else (cond [(eq? name (fundefC-name (first lof))) (first lof)] [else (lookup name (rest lof))])])) ;; return the longer of two strings (first if equal) (define (longer [a : string] [b : string]) : string (cond [(< (string-length a) (string-length b)) b] [else a])) (test (longer "a" "ab") "ab") (test (longer "ba" "a") "ba") (test (longer "z" "q") "z") (test (longer "" "uenthaoeus") "uenthaoeus") (test (eval (strC "horse") empty empty) "horse") (test (eval (longerC (longerC (strC "cat") (strC "bird")) (strC "elephant")) empty empty) "elephant") (test (eval (appC 'banaLong (strC "mountain lion")) empty (list (fundefC 'banaLong 'b (longerC (idC 'b) (strC "banana"))))) "mountain lion") (test/exn (eval (appC 'g (strC "mountain lion")) empty (list (fundefC 'g 'z (appC 'f (idC 'z))) (fundefC 'f 'x (longerC (idC 'x) (idC 'z))))) "no binding for") #;(test (eval2 (parse '{banaLong "mountain lion"}) (list (parse-fundef '{whatis banaLong b {$ b "banana"}}))) "mountain lion") #;(test (eval2 (appC 'banaLong (strC "mountain lion")) (list (fundefC 'banaLong 'b (longerC (idC 'b) (strC "banana"))))) "mountain lion") '(define (f x) (+ x 34)) (s-exp-list? '(define (f x) (+ x 34))) (s-exp-symbol? '(define (f x) (+ x 34))) (s-exp->list '(define (f x) (+ x 34))) )