Skip to content

Instantly share code, notes, and snippets.

@jbclements
Created May 1, 2020 21:08
Show Gist options
  • Save jbclements/4746918c5c18d7d44ac5d349ba3ddc09 to your computer and use it in GitHub Desktop.
Save jbclements/4746918c5c18d7d44ac5d349ba3ddc09 to your computer and use it in GitHub Desktop.
#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?
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment