find-the-diff.rkt

#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"

'{"abc" + "def"}  ; => "abcdef"
'{{"a" + "b"} + "cdef"}
'{"**" around "abc"} ; => "**abc**"

'{lambda {f} {f 7}}
'{f -> {f 7}}
'{{f 7} f function}


;; 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 'fn (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))))]
    [(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 (top-interp1 [s : Sexp]) : Value
  (interp1 (parse s)))

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

(define test-exp '{+ "abc" "def"})


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

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

(cond [(equal? result1 result2)
       'nope-they-are-the-same]
      [else
       'yay-you-found-a-difference!])