make-add-stars-work.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)

;; represents an environment, mapping names to values:
(define-type Env (Listof Binding))
(struct Binding ([name : Symbol] [value : Value]))

;; 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))]))


;; the empty environment
(define empty-env '())

;; 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))

;; 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)])]))

;; convert a value to a printable string
(define (serialize [v : Value])
  (match v
    [(StrV s) (~v s)]
    [(FunV _ _) "#<procedure>"]))


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

(define test-exp '"abcd")

(top-interp2 test-exp)