UNB/ CS/ David Bremner/ teaching/ cs4613/ lectures/ lecture8/ snippet-008.rkt
#lang plait
(define-type FLANG
  [Num  (val : Number)]
  [Add  (l : FLANG) (r : FLANG)]
  [Sub  (l : FLANG) (r : FLANG)]
  [Mul  (l : FLANG) (r : FLANG)]
  [Div  (l : FLANG) (r : FLANG)]
  [Id   (name : Symbol)]
  [Let1 (id : Symbol) (named-expr : FLANG) (bound-body : FLANG)]
  [Lam  (param : Symbol) (body : FLANG)]
  [Call (fun : FLANG) (val : FLANG)]) ; first type!
;; a type for substitution caches:
(define-type Binding
  	     [bind (name : Symbol) (val : FLANG)])

(define-type-alias SubstCache (Listof Binding))
  (define empty-subst empty)
;
  (define (extend id expr sc)
    (cons (bind id expr) sc))
;
;; gets a Racket numeric binary operator, and uses it within a FLANG
;; `Num' wrapper (note H.O type)
(define (arith-op op expr1 expr2)
  (local
      [(define (Num->number e)
         (type-case FLANG e
           [(Num n) n]
           [else (error 'arith-op "expects a number")]))]
    (Num (op (Num->number expr1) 
             (Num->number expr2)))))
(define (lookup name sc)
  (let ([first-name (λ () (bind-name (first sc)))]
        [first-val (λ () (bind-val (first sc)))])
    (cond
      [(empty? sc) (error 'lookup (string-append "missing binding: " (to-string name)))]
      [(eq? name (first-name)) (first-val)]
      [else  (lookup name (rest sc))])))

(define (interp expr sc)
  (type-case FLANG expr
    [(Num n) expr]
    [(Add l r) (arith-op + (interp l sc) (interp r sc))]
    [(Let1 bound-id named-expr bound-body)
     (interp bound-body
           (extend bound-id (interp named-expr sc) sc))]
    [(Id name) (lookup name sc)]

;; Basically pass-through tests for lookup
(module+ test
  (test/exn (interp (Id 'x) empty-subst) "missing")
  (define sc (extend 'x (Num 1) (extend 'y (Num 2) (extend 'z (Num 3) empty-subst))))
  (test (interp (Id 'x) sc) (Num 1))
  (test (interp (Add (Id 'y) (Num -2)) sc) (Num 0)))

;; Tests for Let1/shadowing
(module+ test
  (test (interp (Let1 'x (Num 3) (Id 'x)) sc) (Num 3)))

;; Tests for Lam / Call
(module+ test
  (test (interp (Call (Lam 'x (Id 'x)) (Num 42)) sc) (Num 42))
  (test (interp (Call (Lam 'x (Id 'y)) (Num 42)) sc) (Num 2)))