friday PM example

#lang typed/racket

(require typed/rackunit)

;; an S-expression is one of:
;; a number
;; a string
;; a boolean
;; a symbol, or
;; (list S-expression ...)

;; concrete syntax of TL
"a string"
"abc"
"def"

;; function definitions
'{lam {a} a}
'{lam {b} {+ b "abc"}}


;; abstract syntax of TL
(define-type ExprC (U StrAppdC StrC IdC AppC FunC))
(struct StrC ([s : String]) #:transparent)
(struct IdC ([var : Symbol]) #:transparent)
(struct StrAppdC ([l : ExprC] [r : ExprC]) #:transparent)
(struct AppC ([fun : ExprC] [arg : ExprC]) #:transparent)
(struct FunC ([param : Symbol] [body : ExprC]))

(define-type Value (U StrV FunV))
(struct StrV ([s : String]) #:transparent)
(struct FunV ([param : Symbol] [body : ExprC]) #:transparent)

;; parse concrete stx of 
(define (parse [s : Sexp]) : ExprC
  (match s
    [(? string?) (StrC s)]
    [(? symbol? x) (IdC x)]
    [(list '+ l r) (StrAppdC (parse l) (parse r))]
    [(list 'lam (list (? symbol? param)) body) (FunC param (parse body))]
    [(list fun arg) (AppC (parse fun) (parse arg))]))


(define empty-env '())

(define-type Env (Listof Binding))
(struct Binding ([name : Symbol] [value : Value]))

;; find a binding in an environment
(define (env-lookup [env : Env] [s : Symbol]) : Value
  (match env
    ['() (error 'ouch1)]
    [(cons (Binding name value) r)
     (cond [(equal? name s) value]
           [else (env-lookup r s)])]))

;; extend an environment with a new binding
(define (env-extend [env : Env] [name : Symbol] [value : Value]) : Env
  (cons (Binding name value) env))

;; perform substitution: put "what" in for "for" in "in"
(define (subst [what : ExprC] [for : Symbol] [in : ExprC]) : ExprC
  (match in
    [(IdC s) (cond [(equal? s for) what]
                   [else in])]
    [(StrC s) in]
    [(StrAppdC l r) (StrAppdC (subst what for l) (subst what for r))]
    [(FunC param body) (FunC param (subst what for body))] ;; :)
    [(AppC fun arg) (AppC (subst what for fun) (subst what for arg))]))

;; interpret, using substitution
(define (interp1 [e : ExprC]) : Value
  (match e
    [(StrC s) (StrV s)]
    [(StrAppdC l r) (StrV (string-append (StrV-s (cast (interp1 l) StrV))
                                         (StrV-s (cast (interp1 r) StrV))))]
    [(IdC var) (error 'ouch2)]
    [(FunC param body) (FunV param body)]
    [(AppC f a)
     (define fn (interp1 f))
     (match fn
       [(FunV param body)
        (define argval (interp1 a))
        (define new-body (subst (back2exp argval)
                                param body))
        (interp1 new-body)])]))

(define (back2exp [v : Value]) : ExprC
  (match v
    [(StrV s) (StrC s)]
    [(FunV param body) (FunC param body)]))

;; interpret, using environments
(define (interp2 [e : ExprC] [env : Env]) : Value
  (match e
    [(StrC s) (StrV s)]
    [(StrAppdC l r) (StrV (string-append (StrV-s (cast (interp2 l env) StrV))
                                         (StrV-s (cast (interp2 r env) StrV))))]
    [(FunC param body) (FunV param body)]
    [(IdC var) (env-lookup env var)]
    [(AppC f a)
     (define fn (interp2 f env))
     (match fn
       [(FunV param body)
        (define argval (interp2 a env))
        (define new-env (env-extend empty-env param argval))
        (interp2 body new-env)])]
    ))

(define (serialize [v : Value])
  (match v
    [(StrV s) (~v s)]
    [(FunV _ _) "#<procedure>"]))


(define (top-interp1 [s : Sexp]) : String
  (serialize (interp1 (parse s))))

(define (top-interp2 [s : Sexp]) : String
  (serialize (interp2 (parse s) empty-env)))

(define test-exp '"axgi")


(define (exn-formatter [exn : exn])
  (list 'fail (exn-message exn)))

(define result1
  (with-handlers ([exn:fail? exn-formatter])
    (top-interp1 test-exp)))

(define result2
  (with-handlers ([exn:fail? exn-formatter])
    (top-interp2 test-exp)))

(printf "result of interp1: ~a\n" result1)

(printf "result of interp2: ~a\n" result2)

(cond [(equal? result1 result2)
       (printf "nope, results are the same")]
      [else
       (printf "yay, you found a difference!")])

;; 0) write a function that adds a star, apply it to an argument.
;;    (make sure you take a look at the updated syntax for function defns.)
;; 1) write a curried string-append
;; 2) apply it to two strings
;; 3) does it behave differently in the two interpreters?
;; 4) why?

;; (5) secret question: there's a problem with interp1, too... can you find it?