#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!
(define (parse-error sx)
  (error 'parse-sx (string-append "parse error: " (to-string sx))))

(define (sx-ref sx n) (list-ref (s-exp->list sx) n))

(define (parse-sx sx)
  (cond
    [(s-exp-number? sx) (Num (s-exp->number sx))]
    [(s-exp-symbol? sx) (Id (s-exp->symbol sx))]
    [(s-exp-match? `(let1 (SYMBOL ANY) ANY) sx)
     (let* ([def (sx-ref sx 1)]
            [id (s-exp->symbol (sx-ref def 0))]
            [val (parse-sx (sx-ref def 1))]
            [expr (parse-sx (sx-ref sx 2))])
       (Let1 id val expr))]
    [(s-exp-match? `(lam SYMBOL ANY) sx)
     (let* ([id (s-exp->symbol (sx-ref sx 1))]
            [body (parse-sx (sx-ref sx 2))])
       (Lam id body))]
    [(s-exp-match? `(ANY ANY) sx)
     (Call (parse-sx (sx-ref sx 0))
           (parse-sx (sx-ref sx 1)))]
    [(s-exp-list? sx)
     (let* ([l (λ () (parse-sx (sx-ref sx 1)))]
            [r (λ () (parse-sx (sx-ref sx 2)))])
         (case (s-exp->symbol (sx-ref sx 0))
           [(+) (Add (l) (r))]
           [(-) (Sub (l) (r))]
           [(*) (Mul (l) (r))]
           [(/) (Div (l) (r))]
           [else (parse-error sx)]))]
    [else (parse-error sx)]))

;; 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)))))
;; 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))
;
(define (lookup name sc)
  (if (empty? sc)
      (error 'lookup (string-append "no binding for " (symbol->string name)))
      (type-case Binding (first sc)
        [(bind first-name first-val)
              (if (eq? name first-name)
                  first-val
                  (lookup name (rest sc)))])))
;; evaluates FLANG expressions by reducing them to expressions
(define (interp expr sc)
  (type-case FLANG expr
    [(Num n) expr]
    [(Add l r) (arith-op + (interp l sc) 
			 (interp r sc))]
    [(Sub l r) (arith-op - (interp l sc) (interp r sc))]
    [(Mul l r) (arith-op * (interp l sc) (interp r sc))]
    [(Div 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)]
    [(Lam bound-id bound-body) expr]
    [(Call fun-expr arg-expr)
     (let ([fval (interp fun-expr sc)])
       (type-case FLANG fval
         [(Lam bound-id bound-body)
          (interp bound-body
                (extend bound-id (interp arg-expr sc) sc))]
         [else (error 'eval
                      (string-append "`call' expects a function, got: "
                              (to-string fval)))]))]))

(define (run s-exp)
  (let ([result
         (interp (parse-sx s-exp) empty-subst)])
    (type-case FLANG result
      [(Num n) n]
      [else
       (error 'run (string-append "non-number: " (to-string result)))])))