a parser and interpreter for the CFWAE language

gistfile1.rkt

;; http://www.cs.brown.edu/courses/csci1730/2012/Assignments/Interpreter/

#lang plai

(define-type Binding
  [binding (name symbol?) (named-expr CFWAE?)])

(define-type CFWAE
  [num (n number?)]
  [binop (op procedure?) (lhs CFWAE?) (rhs CFWAE?)]
  [with (lob (listof Binding?)) (body CFWAE?)]
  [id (name symbol?)]
  [if0 (c CFWAE?) (t CFWAE?) (e CFWAE?)]
  [fun (args (listof symbol?)) (body CFWAE?)]
  [app (f CFWAE?) (args (listof CFWAE?))])

(define-type Env
  [mtEnv]
  [anEnv (name symbol?) (value CFWAE-Value?) (env Env?)])

(define (lookup sym env)
  (type-case Env env
    [mtEnv () (error "unbound identifier")]
    [anEnv (n v rest)
           (if (symbol=? sym n)
               v
               (lookup sym rest))]))

(define-type CFWAE-Value
  [numV (n number?)]
  [closureV (params (listof symbol?))
            (body CFWAE?)
            (env Env?)])

(define (num-binop op l r)
  (cond
    [(and (numV? l) (numV? r))
     (numV (op (numV-n l) (numV-n r)))]
    [else (error "both arguments should be numbers")]))

(define binops
  (list (cons '+ (lambda (l r) (num-binop + l r)))
        (cons '- (lambda (l r) (num-binop - l r)))
        (cons '* (lambda (l r) (num-binop * l r)))
        (cons '/ (lambda (l r) (num-binop
                                (lambda (l r)
                                  (if (= 0 r)
                                      (error "divisor shouldn't be zero")
                                      (/ l r)))
                                l r)))))

(define reserved-symbols
  (set-union (set 'if0 'with 'fun)
             (list->set (dict-keys binops))))

;; parse : expression -> CFWAE
; This procedure parses an expression into a CFWAE
(define (parse sexp)
  (cond
    [(number? sexp) (num sexp)]
    [(symbol? sexp) (parse-id sexp)]
    [(and (list? sexp) (not (empty? sexp)))
     (local [(define name (first sexp))]
       (if (set-member? reserved-symbols name)
           (cond 
             [(symbol=? name 'if0) (parse-if0 sexp)]
             [(symbol=? name 'with) (parse-with sexp)]
             [(symbol=? name 'fun) (parse-fun sexp)]
             [else (parse-binop sexp)])
           (parse-app sexp)))]
    [else (error "parse error")]))

(define (parse-id sexp)
  (if (not (set-member? reserved-symbols sexp))
      (id sexp)
      (error "reserved names cannot be used as identifiers")))

(define (parse-if0 sexp)
  (if (= 4 (length sexp))
      (if0 (parse (second sexp))
           (parse (third sexp))
           (parse (fourth sexp)))
      (error "if0 expression should have a test expression, a then branch and a else branch")))

(define (parse-bindings sexp)
  (cond
    [(not (and (list? sexp)
               (andmap (lambda (l) (and (list? l)
                                        (= 2 (length l))
                                        (symbol? (first l))))
                       sexp)))
     (error "bindings should be a list of pairs, each of which consists of a symbol and an expression")]
    [(not (= (length sexp)
             (set-count (list->set (map first sexp)))))
     (error "identifiers in a binding list should be different from each other")]
    [else (map (lambda (l) (binding (first l)
                                    (parse (second l))))
               sexp)]))

(define (parse-with sexp)
  (if (= 3 (length sexp))
      (with (parse-bindings (second sexp))
            (parse (third sexp)))
      (error "with expression should have a binding part and a body")))

(define (parse-args sexp)
  (if (and
       (list? sexp)
       (andmap symbol? sexp)
       (= (length sexp)
          (set-count (list->set sexp))))
      sexp
      (error "arguments should be symbols that are different from each other")))

(define (parse-fun sexp)
  (if (= 3 (length sexp))
      (fun (parse-args (second sexp))
           (parse (third sexp)))
      (error "fun expression should have an argument list and a body")))
(define (parse-app sexp)
  (app (parse (first sexp))
       (map parse (rest sexp))))

(define (parse-binop sexp)
  (if (= 3 (length sexp))
      (binop (dict-ref binops (first sexp))
             (parse (second sexp))
             (parse (third sexp)))
      (error "binary operation should take 2 arguments")))

;; interp : CFWAE -> CFWAE-Value
;; This procedure evaluates a CFWAE expression, producing a CFWAE-Value.
(define (interp expr)
  (interp-in-env expr (mtEnv)))

(define (interp-in-env expr env)
  (type-case CFWAE expr
    [num (n) (numV n)]
    [id (n) (lookup n env)]
    [binop (op lhs rhs) (op (interp-in-env lhs env)
                            (interp-in-env rhs env))]
    [with (lob body) (local [(define new-env
                               (foldl (lambda (b e)
                                        (anEnv (binding-name b)
                                               (interp-in-env (binding-named-expr b) env)
                                               e))
                                      env lob))]
                       (interp-in-env body new-env))]
    [if0 (c t e) (local [(define cv (interp-in-env c env))]
                   (cond
                     [(not (numV? cv)) (error "test expression evalute to a number")]
                     [else (if (equal? (numV 0) cv)
                               (interp-in-env t env)
                               (interp-in-env e env))]))]
    [fun (args body) (closureV args body env)]
    [app (f args) (local [(define c (interp-in-env f env))]
                    (if (and (closureV? c)
                             (= (length (closureV-params c))
                                (length args)))
                        (interp-in-env (closureV-body c)
                                       (foldl (lambda (a ex e) (anEnv a (interp-in-env ex env) e))
                                              (closureV-env c)
                                              (closureV-params c)
                                              args))
                        (error "only functions can be applied")))]))