UNB/ CS/ David Bremner/ teaching/ cs4613/ tests/ final/ call-with-skeleton.rkt
#lang plait
(define-type Exp
  [numE (val : Number)]
  [plusE (l : Exp) (r : Exp)]
  [varE (name : Symbol)]
  [let1E (id : Symbol) (named-expr : Exp) (bound-body : Exp)]
  [lamE (param : Symbol) (body : Exp)]
  [callWith (id : Symbol) (bound-expr : Exp) (fun : Exp) (val : Exp)]
  [appE (fun : Exp) (val : Exp)])

(define-type Value
  [numV (n : Number)]
  [lamV (arg : Symbol) (body : Exp) (env : Env)])

(define-type-alias Env (Hashof Symbol Value))
(define mt-env (hash empty)) ;; "empty environment"

(define (lookup (s : Symbol) (n : Env))
  (type-case (Optionof Value) (hash-ref n s)
    [(none) (error s "not bound")]
    [(some v) v]))

(define (extend old-env new-name value)
  (hash-set old-env new-name value))

(define (interp expr env)
  (type-case Exp expr
    [(numE n) (numV n)]
    [(plusE l r)
     (numV (+ (numV-n (interp l env)) (numV-n (interp r env))))]
    [(let1E bound-id named-expr bound-body)
     (interp bound-body (extend env bound-id (interp named-expr env)))]
    [(varE name) (lookup name env)]
    [(lamE bound-id bound-body) (lamV bound-id bound-body env)]
    [(callWith with-id with-expr fun-expr arg-expr) ....]
    [(appE fun-expr arg-expr)
     (let ([fval (interp fun-expr env)])
       (type-case Value fval
         [(lamV bound-id bound-body f-env)
          (interp bound-body
                  (extend f-env bound-id (interp arg-expr env)))]
         [else (error 'interp
                      (string-append "`call' expects a function, got: "
                                     (to-string fval)))]))]))

(module+ test
  (print-only-errors #t)
  (define (example body)
    (let1E 'x (numE 3)
           (let1E 'f (lamE 'y (plusE (varE 'x) (varE 'y)))
                  body)))


  (test (interp (example (appE (varE 'f) (numE 4))) mt-env)
        (numV 7))

  (test (interp
         (example (callWith 'x (numE 5) (varE 'f) (numE 4))) mt-env)
        (numV 9))

  (test (interp
         (example
          (let1E 'f (lamE 'x (varE 'x))
                 (callWith 'x (numE 5) (varE 'f) (numE 4))))
         mt-env)
        (numV 4))

  (test (interp
         (example
          (let1E 'f (lamE 'y (varE 'x))
                 (callWith 'x (numE 5) (varE 'f) (numE 4))))
         mt-env)
        (numV 5))

  (test
   (interp (callWith 'y (numE 7) (lamE 'x  (plusE (varE 'x) (varE 'y))) (numE 3))
           mt-env)
   (numV 10))
  
  (test/exn
   (interp (callWith 'x (numE 7) (lamE 'x  (plusE (varE 'x) (varE 'y))) (numE 3))
           mt-env)
   "not bound")

  (test
   (interp 
    (callWith 'x (numE 7) (lamE 'x  (plusE (varE 'x) (varE 'x))) (numE 3))
    mt-env)
   (numV 6))

  (test
   (interp
    (let1E 'z (numE 7)
           (callWith 'y (varE 'z) (lamE 'x  (plusE (varE 'x) (varE 'y))) (numE 3)))
    mt-env)
   (numV 10))
  (test
   (interp
    (let1E 'f (lamE 'x  (plusE (varE 'x) (varE 'y)))
           (callWith 'y (numE 7) (varE 'f) (numE 3)))
    mt-env)
   (numV 10))
  (test
   (interp
    (let1E 'f  (lamE 'x  (plusE (varE 'x) (varE 'y)))
           (let1E 'z (numE 7) (callWith 'y (varE 'z) (varE 'f) (numE 3))))
    mt-env)
   (numV 10))

  (test/exn (interp (appE (varE 'g) (numE 4)) mt-env) "not bound")
  (test/exn (interp (example (appE (numE 4) (varE 'f))) mt-env) "function")
  (test/exn (interp (example (callWith 'x (numE 5) (numE 4) (varE 'f))) mt-env) "function"))