Skip to content

Instantly share code, notes, and snippets.

@jbclements
Created May 1, 2020 17:04
Show Gist options
  • Save jbclements/eff2b5f386acda112c6fa14206ec2561 to your computer and use it in GitHub Desktop.
Save jbclements/eff2b5f386acda112c6fa14206ec2561 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"
'{"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 CloV))
(struct StrV ([s : String]) #:transparent)
(struct CloV ([param : Symbol] [body : ExprC]
[env : Env])
#: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 'env-lookup "name not found: ~e" s)]
[(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) (CloV param body env)]
[(IdC var) (env-lookup env var)]
[(AppC f a)
(define fn (interp2 f env))
(define argval (interp2 a env))
(match fn
[(CloV param body clo-env)
(define new-env (env-extend clo-env param argval))
(interp2 body new-env)])]
))
(define (serialize [v : Value])
(match v
[(StrV s) (~v s)]
[(CloV _ _ _) "#<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
'{{{lam {a} {lam {b} {+ a b}}} "abc"} "def"})
(top-interp2 test-exp)
#;(
(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!]))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment