;; Advanced Student Parser

;; Copyright (c) 2008 David Van Horn
;; Licensed under the Academic Free License version 3.0

;; (at dvanhorn (dot ccs neu edu))

;; This module implements an S-Expression parser for
;; Advanced Student syntax.

;; This code is written to be consistent with the parsing
;; done by DrScheme.  The hope is that this code signals
;; and error iff DrScheme would (WWDSD?).  It remains
;; to make the error messages consistent as well.

#lang scheme
(require htdp/testing)
(require lang/htdp-advanced)
(provide (all-defined-out))

(require "data.scm")

(define (parse-error-msg production sexp)
  (format "~a: malformed syntax: ~a" production sexp))

(define (parse-error production sexp)
  (error production (format "malformed syntax: ~a" sexp)))

(define (define-keyword? x)
  (and (symbol? x)
       (case x
         [(define define-struct) true]
         [else false])))

(define (expr-keyword? x)
  (or (head-keyword? x)
      (identifier-keyword? x)))

;; keywords that must appear in head position.
(define (head-keyword? x)
  (and (symbol? x)
       (case x
         [(begin begin0 set! delay lambda local letrec 
                 shared let let* recur cond case else 
                 if when unless and or time quote 
                 quasiquote unquote unquote-splicing)
          true]
         [else false])))

;; keywords that may appear in any expression position.
(define (identifier-keyword? x)
  (and (symbol? x)
       (case x
         [(empty true false) true]
         [else false])))
       
(define (test-case-keyword? x)
  (and (symbol? x)
       (case x
         [(check-expect check-within check-error) true]
         [else false])))

(define (require-keyword? x)
  (and (symbol? x)
       (symbol=? x 'require)))

;; name? : Any -> Boolean
;; A name is any symbol k for which (lambda (k) k) is
;; allowed.
(define (name? x)
  (and (symbol? x)
       (not (any-keyword? x))))

(define (any-keyword? x)
  (or (define-keyword? x)
      (expr-keyword? x)
      (test-case-keyword? x)
      (require-keyword? x)))

;; Programs
;; ========

;; parse-program : SExpr -> Program
(define (parse-program sexp)
  (if (list? sexp)
      (map parse-def-or-expr sexp)
      (parse-error 'parse-program sexp)))

(check-expect (parse-program empty) empty)
(check-expect (parse-program '{ 1 }) (list (parse-expr 1)))
(check-error (parse-program 'x)
             (parse-error-msg 'parse-program 'x))

(define (parse-def-or-expr sexp)
  (cond [(and (cons? sexp) (symbol? (first sexp)))
         (case (first sexp)
           [(define define-struct)
            (parse-definition sexp)]
           [(check-expect check-within check-error)
            (parse-test-case sexp)]
           [(require)
            (parse-library-require sexp)]
           [else
            (parse-expr sexp)])]
        [else
         (parse-expr sexp)]))

(check-expect (parse-def-or-expr 1)
              (parse-expr 1))
(check-expect (parse-def-or-expr '(f x))
              (parse-expr '(f x)))
(check-expect (parse-def-or-expr '(define x 1))
              (parse-definition '(define x 1)))
(check-expect (parse-def-or-expr '(check-expect x y))
              (parse-test-case '(check-expect x y)))
(check-expect (parse-def-or-expr '(require "f"))
              (parse-library-require '(require "f")))


;; Definitions
;; ===========

(define (parse-define sexp)
  (if (= 3 (length sexp))
      (cond [(name? (second sexp)) 
             (make-<definition-value> (make-<identifier> (second sexp))
                                      (parse-expr (third sexp)))]
            [(and (list? (second sexp))
                  (not (empty? (second sexp)))
                  (andmap name? (second sexp)))
             (make-<definition-procedure> (make-<identifier> (first (second sexp)))
                                          (map make-<identifier> (rest (second sexp)))
                                          (parse-expr (third sexp)))]
            [else
             (parse-error 'parse-define sexp)])
      (parse-error 'parse-define sexp)))
      
(define (parse-define-struct sexp)
  (if (and (= 3 (length sexp))
           (name? (second sexp))
           (list? (third sexp))
           (andmap name? (third sexp)))
      (make-<definition-struct> 
       (make-<identifier> (second sexp))
       (map make-<identifier> (third sexp)))
      (parse-error 'parse-define-struct sexp)))

(define (parse-definition sexp)
  (cond [(and (pair? sexp) (define-keyword? (first sexp)))
         (case (first sexp)
           [(define)        (parse-define sexp)]
           [(define-struct) (parse-define-struct sexp)])]
        [else
         (parse-error 'parse-definition sexp)]))

(check-expect (parse-definition '(define x 1))
              (make-<definition-value> (make-<identifier> 'x)
                                       (parse-expr 1)))
(check-expect (parse-definition '(define (x) 1))
              (make-<definition-procedure> (make-<identifier> 'x)
                                           empty
                                           (parse-expr 1)))
(check-expect (parse-definition '(define-struct f ()))
              (make-<definition-struct> (make-<identifier> 'f) empty))
(check-expect (parse-definition '(define-struct f (x)))
              (make-<definition-struct> (make-<identifier> 'f) (list (make-<identifier> 'x))))
(check-error (parse-definition '(define-struct f (1)))
             (parse-error-msg 'parse-define-struct '(define-struct f (1))))
(check-error (parse-definition 1)
             (parse-error-msg 'parse-definition 1))
(check-error (parse-definition '(define x y z))
             (parse-error-msg 'parse-define '(define x y z)))
(check-error (parse-definition '(defun x 1))
             (parse-error-msg 'parse-definition '(defun x 1)))
(check-error (parse-definition '(define (f 1) x))
             (parse-error-msg 'parse-define '(define (f 1) x)))



;; Expressions
;; ===========

;; parse-id+exprs : Symbol SExpr SExpr ([Listof Id] [Listof Expr] -> X) -> X
;; Purpose: to parse a potential list of bindings: ((id expr) ...).  If
;; it parses, then k is called on the list of ids and exprs.
;; The parameters name and ctx are used for error reporting only
;; and represent the context of this list of bindings.
(define (parse-id+exprs name ctx sexp k)
  ;; ((id expr) ...)
  (local [(define (parse-id+exprs-accum sexp ids exprs)
            (cond [(empty? sexp) (k (reverse ids) (reverse exprs))]
                  [(and (list? sexp)
                        (list? (first sexp))
                        (= 2 (length (first sexp)))
                        (name? (first (first sexp))))
                   (parse-id+exprs-accum 
                    (rest sexp)
                    (cons (make-<identifier> (first (first sexp))) ids)
                    (cons (parse-expr (second (first sexp))) exprs))]
                  [else
                   (parse-error name ctx)]))]
    (parse-id+exprs-accum sexp empty empty)))
                
(check-expect (parse-id+exprs 'name 'ctx empty list)
              (list empty empty))
(check-expect (parse-id+exprs 'name 'ctx '((x 1)) list)
              (list (list (make-<identifier> 'x))
                    (list (parse-expr 1))))
(check-error (parse-id+exprs 'name 'ctx '(1) list)
             (parse-error-msg 'name 'ctx))


;; parse-let-helper : Symbol SExpr ([Listof Id] [Listof Expr] Expr -> X) -> X
;; Purpose: parse potential "let-like" expressions: (_ ((id expr) ...) expr).
;; If it parses, the given constructor is applied.
;; The parameter name is used for error reporting.
(define (parse-let-helper name sexp k)
  ;; (let ((id expr) ...) expr)
  (if (and (= 3 (length sexp))
           (list? (second sexp)))
      (parse-id+exprs name sexp (second sexp)
                      (lambda (ids exprs)
                        (k ids exprs (parse-expr (third sexp)))))
      (parse-error name sexp)))

(check-expect (parse-let-helper 'name '(_ () x) list)
              (list empty empty (parse-expr 'x)))
(check-expect (parse-let-helper 'name '(_ ((x 1)) x) list)
              (list (list (make-<identifier> 'x))
                    (list (parse-expr 1))
                    (parse-expr 'x)))
(check-error (parse-let-helper 'name '(_ x) list)
             (parse-error-msg 'name '(_ x)))
                          

;; parse-named-let-helper : Symbol SExpr (Id [Listof Id] [Listof Expr] Expr -> X) -> X
;; Purpose: parse potential "named let-like" expressions: (_ id ((id expr) ...) expr).
;; If it parses, the given constructor is applied.
;; The parameter name is used for error reporting.
(define (parse-named-let-helper name sexp k)
  ;; (let id ((id expr) ...) expr)
  (if (and (= 4 (length sexp))
           (name? (second sexp))
           (list? (third sexp)))
      (parse-id+exprs name sexp (third sexp)
                      (lambda (ids exprs)
                        (k (make-<identifier> (second sexp))
                           ids exprs (parse-expr (fourth sexp)))))
      (parse-error name sexp)))

(check-expect (parse-named-let-helper 'name '(_ f () x) list)
              (list (make-<identifier> 'f)
                    empty
                    empty
                    (make-<identifier> 'x)))
(check-expect (parse-named-let-helper 'name '(_ f ((x 1)) x) list)
              (list (make-<identifier> 'f)
                    (list (make-<identifier> 'x))
                    (list (parse-expr 1))
                    (make-<identifier> 'x)))
(check-error (parse-named-let-helper 'name '(_ x) list)
             (parse-error-msg 'name '(_ x)))


;; parse-begin-helper : Symbol SExpr ([Listof Id] -> X) -> X
;; Purpose: parse potential "begin-like" expressions: (_ expr expr ...).
;; If it parses, the given constructor is applied.
;; The parameter name is used for error reporting.
(define (parse-begin-helper name sexp k)
  ;; (begin expr expr ...)
  (if (not (empty? (rest sexp)))
      (k (map parse-expr (rest sexp)))
      (parse-error name sexp)))

(check-expect (parse-begin-helper 'name '(_ 1) identity)
              (list (parse-expr 1)))
(check-expect (parse-begin-helper 'name '(_ 1 2) identity)
              (list (parse-expr 1)
                    (parse-expr 2)))
(check-error (parse-begin-helper 'name '(_) identity)
             (parse-error-msg 'name '(_)))


;; parse-delay-helper : Symbol SExpr (Expr -> X) -> X
;; Purpose: parse potential "delay-like" expressions: (_ expr).
(define (parse-delay-helper name sexp k)
  (if (= 2 (length sexp))
      (k (parse-expr (second sexp)))
      (parse-error name sexp)))

(check-expect (parse-delay-helper 'name '(_ x) identity)
              (parse-expr 'x))
(check-error (parse-delay-helper 'name '(_) identity)
             (parse-error-msg 'name '(_)))
(check-error (parse-delay-helper 'name '(_ x y) identity)
             (parse-error-msg 'name '(_ x y)))

;; parse-when-helper : Symbol SExpr (Expr Expr -> X) -> X
;; Purpose: parse potential "when-like" expressions: (_ expr expr).
(define (parse-when-helper name sexp k)
  (if (= 3 (length sexp))
      (k (parse-expr (second sexp)) (parse-expr (third sexp)))
      (parse-error name sexp)))

(check-expect (parse-when-helper 'name '(_ x y) list)
              (list (parse-expr 'x) (parse-expr 'y)))
(check-error (parse-when-helper 'name '(_ x) list)
             (parse-error-msg 'name '(_ x)))
(check-error (parse-when-helper 'name '(_) list)
             (parse-error-msg 'name '(_)))

;; parse-and-helper : Symbol SExpr ([Listof Expr] -> X) -> X
(define (parse-and-helper name sexp k)
  (if (<= 3 (length sexp))
      (k (map parse-expr (rest sexp)))
      (parse-error name sexp)))

(check-expect (parse-and-helper 'name '(_ x y) identity)
              (map parse-expr '(x y)))
(check-expect (parse-and-helper 'name '(_ x y z) identity)
              (map parse-expr '(x y z)))
(check-error (parse-and-helper 'name '(_ x) identity)
             (parse-error-msg 'name '(_ x)))


(define (parse-begin sexp)
  (parse-begin-helper 'parse-begin sexp make-<begin>))
(define (parse-begin0 sexp)
  (parse-begin-helper 'parse-begin0 sexp make-<begin0>))

(define (parse-set! sexp)
  (if (and (= 3 (length sexp))
           (name? (second sexp)))
      (make-<set!> (make-<identifier> (second sexp)) 
                   (parse-expr (third sexp)))
      (parse-error 'parse-set! sexp)))

(define (parse-delay sexp)
  (parse-delay-helper 'parse-delay sexp make-<delay>))

(define (parse-if sexp)
  (if (= 4 (length sexp))
      (make-<if> (parse-expr (second sexp))
                 (parse-expr (third sexp))
                 (parse-expr (fourth sexp)))
      (parse-error 'parse-if  sexp)))

(define (parse-when sexp)
  (parse-when-helper 'parse-when sexp make-<when>))
(define (parse-unless sexp)
  (parse-when-helper 'parse-unless sexp make-<unless>))
(define (parse-and sexp)
  (parse-and-helper 'parse-and sexp make-<and>))
(define (parse-or sexp)
  (parse-and-helper 'parse-or sexp make-<or>))

(define (parse-time sexp)
  (parse-delay-helper 'parse-time sexp make-<time>))

(define (parse-lambda sexp)
  ;; (lambda (id ...) expr)
  (if (and (= 3 (length sexp))
           (list? (second sexp))
           (andmap name? (second sexp)))
      (make-<lambda> (map make-<identifier> (second sexp))
                     (parse-expr (third sexp)))
      (parse-error 'parse-lambda sexp)))

(define (parse-local sexp)
  ;; (local [definition ...] expr)
  (if (and (= (length sexp) 3)
           (list? (second sexp)))
      (make-<local> (map parse-definition (second sexp))
                    (parse-expr (third sexp)))
      (parse-error 'parse-local sexp)))

(define (parse-letrec sexp)
  (parse-let-helper 'parse-let sexp make-<letrec>))
(define (parse-let sexp)
  (case (length sexp)
    [(3) (parse-let-helper 'parse-let sexp make-<let>)]
    [(4) (parse-named-let-helper 'parse-named-let sexp make-<recur>)]
    [else (parse-error 'parse-let sexp)]))
(define (parse-let* sexp)
  (parse-let-helper 'parse-let* sexp make-<let*>))
(define (parse-shared sexp)
  (parse-let-helper 'parse-shared sexp make-<shared>))
(define (parse-recur sexp)
  (parse-named-let-helper 'parse-recur sexp make-<recur>))

(define (parse-cond sexp)
  (local [(define (parse-cond-clauses-accum cs qs as)
            (if (and (pair? cs)
                     (list? (first cs))
                     (= 2 (length (first cs))))
                (if (empty? (rest cs))
                    (if (symbol=? (first (first cs)) 'else)
                        (make-<cond/else> (reverse qs) (reverse as) (parse-expr (second (first cs))))
                        (make-<cond> (reverse (cons (parse-expr (first (first cs))) qs))
                                     (reverse (cons (parse-expr (second (first cs))) as))))
                    (parse-cond-clauses-accum 
                     (rest cs)
                     (cons (parse-expr (first (first cs))) qs)
                     (cons (parse-expr (second (first cs))) as)))
                (parse-error 'parse-cond sexp)))]
    (parse-cond-clauses-accum (rest sexp) empty empty)))

(define (choice? x)
  (or (number? x)
      (symbol? x)))
            
(define (parse-choice sexp)
  (cond [(number? sexp) (make-<number> sexp)]
        [(symbol? sexp) (make-<identifier> sexp)]))
          
(define (parse-case sexp)
  (local [(define (parse-case-lines-accum ls cs as)
            (if (and (pair? ls)
                     (list? (first ls))
                     (= 2 (length (first ls)))
                     (or (and (list? (first (first ls)))
                              (andmap choice? (first (first ls))))
                         (and (symbol? (first (first ls)))
                              (symbol=? 'else (first (first ls))))))
                (if (empty? (rest ls))
                    (if (and (symbol? (first (first ls))) 
                             (symbol=? (first (first ls)) 'else))
                        (make-<case/else> (parse-expr (second sexp))
                                          (reverse cs)
                                          (reverse as)
                                          (parse-expr (second (first ls))))
                        (make-<case> (parse-expr (second sexp))
                                     (reverse (cons (map parse-choice (first (first ls))) cs))
                                     (reverse (cons (parse-expr (second (first ls))) as))))
                    (parse-case-lines-accum 
                     (rest ls)
                     (cons (map parse-choice (first (first ls))) cs)
                     (cons (parse-expr (second (first ls))) as)))
                (parse-error 'parse-case sexp)))]
    
    (if (<= 3 (length sexp))
        (parse-case-lines-accum (rest (rest sexp)) empty empty) 
        (parse-error 'parse-case sexp))))
           
(define (parse-quote sexp)
  ;; 'id or 'quoted (quoted value)
  (if (= 2 (length sexp))
      (make-<quote> (parse-quoted (second sexp)))
      (parse-error 'parse-quote sexp)))

(define (parse-quoted sexp)
  (cond [(symbol? sexp)
         (make-<identifier> sexp)]
        [(number? sexp)
         (make-<number> sexp)]
        [(string? sexp)
         (make-<string> sexp)]
        [(char? sexp)
         (make-<character> sexp)]
        [(list? sexp)
         (make-<quoted-list> (map parse-quoted sexp))]))
        
             

(define (parse-application sexp)
  (make-<application> (parse-expr (first sexp))
                      (map parse-expr (rest sexp))))

;; parse-expr : SExpr -> Expr
;; Purpose: parse a potential expression.
(define (parse-expr sexp)
  (cond [(and (pair? sexp) (head-keyword? (first sexp)))
         (case (first sexp)
           [(begin)  (parse-begin sexp)]
           [(begin0) (parse-begin0 sexp)]
           [(set!)   (parse-set! sexp)]
           [(delay)  (parse-delay sexp)]
           [(lambda) (parse-lambda sexp)]
           [(local)  (parse-local sexp)]
           [(letrec) (parse-letrec sexp)]
           [(shared) (parse-shared sexp)]
           [(let)    (parse-let sexp)]
           [(let*)   (parse-let* sexp)]
           [(recur)  (parse-recur sexp)]
           [(cond)   (parse-cond sexp)]
           [(case)   (parse-case sexp)]
           [(if)     (parse-if sexp)]
           [(when)   (parse-when sexp)]
           [(unless) (parse-unless sexp)]
           [(and)    (parse-and sexp)]
           [(or)     (parse-or sexp)]
           [(time)   (parse-time sexp)]
           [(quote)  (parse-quote sexp)])]
        [(cons? sexp)   (parse-application sexp)]
        [(name? sexp)   (make-<identifier> sexp)]
        [(number? sexp) (make-<number> sexp)]
        [(string? sexp) (make-<string> sexp)]
        [(char? sexp)   (make-<character> sexp)]
        [(identifier-keyword? sexp)
         (case sexp
           [(empty) (make-<empty>)]
           [(true)  (make-<true>)]
           [(false) (make-<false>)])]
        [else (parse-error 'parse-expr sexp)]))

(check-expect (parse-expr 'empty)
              (make-<empty>))
(check-expect (parse-expr 'true)
              (make-<true>))
(check-expect (parse-expr 'false)
              (make-<false>))
(check-expect (parse-expr 5)
              (make-<number> 5))
(check-expect (parse-expr #\a)
              (make-<character> #\a))
(check-expect (parse-expr "hi")
              (make-<string> "hi"))
(check-expect (parse-expr '(f x))
              (make-<application> (parse-expr 'f) (list (parse-expr 'x))))
(check-expect (parse-expr '(begin x))
              (make-<begin> (list (parse-expr 'x))))
(check-expect (parse-expr '(begin0 x))
              (make-<begin0> (list (parse-expr 'x))))
(check-expect (parse-expr '(set! x y))
              (make-<set!> (make-<identifier> 'x)
                           (parse-expr 'y)))
(check-error (parse-expr '(set! 1 x))
             (parse-error-msg 'parse-set! '(set! 1 x)))
(check-expect (parse-expr '(delay x))
              (make-<delay> (parse-expr 'x)))
(check-expect (parse-expr '(let () 1))
              (make-<let> empty empty (parse-expr 1)))
(check-expect (parse-expr '(let* () 1))
              (make-<let*> empty empty (parse-expr 1)))
(check-expect (parse-expr '(letrec () 1))
              (make-<letrec> empty empty (parse-expr 1)))
(check-expect (parse-expr '(shared () 1))
              (make-<shared> empty empty (parse-expr 1)))
(check-expect (parse-expr '(let ((x 1)) x))
              (make-<let> (list (make-<identifier> 'x))
                          (list (parse-expr 1))
                          (parse-expr 'x)))
(check-expect (parse-expr '(let ((x 1) (y 2)) x))
              (make-<let> (list (make-<identifier> 'x)
                                (make-<identifier> 'y))
                          (list (parse-expr 1)
                                (parse-expr 2))
                          (parse-expr 'x)))
(check-expect (parse-expr '(let f () x))
              (make-<recur> (make-<identifier> 'f)
                            empty
                            empty
                            (parse-expr 'x)))
(check-expect (parse-expr '(let f ((x 1)) x))
              (make-<recur> (make-<identifier> 'f)
                            (list (make-<identifier> 'x))
                            (list (parse-expr 1))
                            (parse-expr 'x)))
(check-error (parse-expr '(let f))
             (parse-error-msg 'parse-let '(let f)))
(check-expect (parse-expr '(cond [x y]))
              (make-<cond> (list (parse-expr 'x))
                           (list (parse-expr 'y))))
(check-expect (parse-expr '(cond [u v] [w x]))
              (make-<cond> (list (parse-expr 'u) (parse-expr 'w))
                           (list (parse-expr 'v) (parse-expr 'x))))
(check-expect (parse-expr '(cond [else x]))
              (make-<cond/else> empty empty (parse-expr 'x)))
(check-expect (parse-expr '(cond [u v] [else w]))
              (make-<cond/else> (list (parse-expr 'u))
                                (list (parse-expr 'v))
                                (parse-expr 'w)))
(check-error (parse-expr '(cond x))
             (parse-error-msg 'parse-cond '(cond x)))
(check-error (parse-expr '(cond [x]))
             (parse-error-msg 'parse-cond '(cond (x))))
(check-error (parse-expr '(cond [x y z]))
             (parse-error-msg 'parse-cond '(cond (x y z))))

(check-expect (parse-expr '(case x [(1) x]))
              (make-<case> (parse-expr 'x)
                           (list (list (parse-choice 1)))
                           (list (parse-expr 'x))))
(check-expect (parse-expr '(case x [(a) x]))
              (make-<case> (parse-expr 'x)
                           (list (list (parse-choice 'a)))
                           (list (parse-expr 'x))))
(check-expect (parse-expr '(case x [(a 1) x]))
              (make-<case> (parse-expr 'x)
                           (list (list (parse-choice 'a) (parse-choice 1)))
                           (list (parse-expr 'x))))
(check-expect (parse-expr '(case x [(1) x] [(b) y]))
              (make-<case> (parse-expr 'x)
                           (list (list (parse-choice '1)) (list (parse-choice 'b)))
                           (list (parse-expr 'x) (parse-expr 'y))))
(check-error (parse-expr '(case x))
             (parse-error-msg 'parse-case '(case x)))
(check-error (parse-expr '(case x ["f" x]))
             (parse-error-msg 'parse-case '(case x ["f" x])))
(check-expect (parse-expr '(case x [(a) x] [else z]))
              (make-<case/else> (parse-expr 'x)
                                (list (list (parse-choice 'a)))
                                (list (parse-expr 'x))
                                (parse-expr 'z)))
(check-expect (parse-expr '(case x [(a 1) x] [else z]))
              (make-<case/else> (parse-expr 'x)
                                (list (list (parse-choice 'a) (parse-choice 1)))
                                (list (parse-expr 'x))
                                (parse-expr 'z)))
(check-expect (parse-expr '(case x [(1) x] [(b) y] [else z]))
              (make-<case/else> (parse-expr 'x)
                                (list (list (parse-choice '1)) (list (parse-choice 'b)))
                                (list (parse-expr 'x) (parse-expr 'y))
                                (parse-expr 'z)))
(check-expect (parse-expr '(recur f () x))
              (make-<recur> (make-<identifier> 'f)
                            empty
                            empty
                            (parse-expr 'x)))
(check-expect (parse-expr '(recur f ((x 1)) x))
              (make-<recur> (make-<identifier> 'f)
                            (list (make-<identifier> 'x))
                            (list (parse-expr 1))
                            (parse-expr 'x)))                                
(check-expect (parse-expr '(if x y z))
              (make-<if> (parse-expr 'x)
                         (parse-expr 'y)
                         (parse-expr 'z)))
(check-error (parse-expr '(if x))
             (parse-error-msg 'parse-if '(if x)))
(check-error (parse-expr '(if x y))
             (parse-error-msg 'parse-if '(if x y)))
(check-expect (parse-expr '(when x y))
              (make-<when> (parse-expr 'x)
                           (parse-expr 'y)))
(check-expect (parse-expr '(unless x y))
              (make-<unless> (parse-expr 'x)
                             (parse-expr 'y)))
(check-expect (parse-expr '(and x y))
              (make-<and> (map parse-expr '(x y))))
(check-expect (parse-expr '(and x y z))
              (make-<and> (map parse-expr '(x y z))))
(check-expect (parse-expr '(or x y))
              (make-<or> (map parse-expr '(x y))))
(check-expect (parse-expr '(or x y z))
              (make-<or> (map parse-expr '(x y z))))
(check-expect (parse-expr '(time x))
              (make-<time> (parse-expr 'x)))
(check-expect (parse-expr '(lambda () x))
              (make-<lambda> empty (parse-expr 'x)))
(check-expect (parse-expr '(lambda (x) x))
              (make-<lambda> (list (make-<identifier> 'x))
                             (parse-expr 'x)))
(check-expect (parse-expr '(lambda (x y z) x))
              (make-<lambda> (list (make-<identifier> 'x)
                                   (make-<identifier> 'y)
                                   (make-<identifier> 'z))
                             (parse-expr 'x)))
(check-error (parse-expr '(lambda (1) x))
             (parse-error-msg 'parse-lambda '(lambda (1) x)))
(check-expect (parse-expr '(local () x))
              (make-<local> empty (parse-expr 'x)))
(check-expect (parse-expr '(local ((define x 1)) x))
              (make-<local> (list (parse-definition '(define x 1)))
                            (parse-expr 'x)))
(check-error (parse-expr '(local () x y))
             (parse-error-msg 'parse-local '(local () x y)))
(check-error (parse-expr '(local x y))
             (parse-error-msg 'parse-local '(local x y)))
(check-expect (parse-expr '((f g) x))
              (make-<application>
               (make-<application> (parse-expr 'f)
                                   (list (parse-expr 'g)))
               (list (parse-expr 'x))))
(check-error (parse-expr '(lambda (lambda) lambda))
             (parse-error-msg 'parse-lambda '(lambda (lambda) lambda)))
(check-error (parse-expr '(lambda (quote) quote))
             (parse-error-msg 'parse-lambda '(lambda (quote) quote)))
(check-expect (parse-expr '(quote x))
              (make-<quote> (make-<identifier> 'x)))
(check-expect (parse-expr '(quote quote))
              (make-<quote> (make-<identifier> 'quote)))
(check-expect (parse-expr '(quote 3))
              (make-<quote> (make-<number> 3)))
(check-expect (parse-expr '(quote "s"))
              (make-<quote> (make-<string> "s")))
(check-expect (parse-expr '(quote #\c))
              (make-<quote> (make-<character> #\c)))
(check-expect (parse-expr '(quote ()))
              (make-<quote> (make-<quoted-list> empty)))
(check-expect (parse-expr '(quote (x y lambda)))
              (make-<quote> (make-<quoted-list> 
                             (list (make-<identifier> 'x)
                                   (make-<identifier> 'y)
                                   (make-<identifier> 'lambda)))))
(check-error (parse-expr '(quote x y))
             (parse-error-msg 'parse-quote '(quote x y)))
(check-error (parse-expr 'quote)
             (parse-error-msg 'parse-expr 'quote))

;; Test cases
;; ==========

(define (parse-test-case s)
  (case (first s)
    [(check-expect)
     (cond [(and (list? s) (= 3 (length s)))
            (make-<check-expect> (parse-expr (second s))
                                 (parse-expr (third s)))]
           [else (parse-error 'check-expect s)])]
    [(check-within)
     (cond [(and (list? s) (= 4 (length s)))
            (make-<check-within> (parse-expr (second s))
                                 (parse-expr (third s))
                                 (parse-expr (fourth s)))]
           [else (parse-error 'check-within s)])]
    [(check-error)
     (cond [(and (list? s) (= 3 (length s)))
            (make-<check-error> (parse-expr (second s))
                                (parse-expr (third s)))]
           [else (parse-error 'check-error s)])]))


(check-expect (parse-test-case '(check-expect e1 e2))
              (make-<check-expect> (parse-expr 'e1) (parse-expr 'e2)))
(check-expect (parse-test-case '(check-within e1 e2 e3))
              (make-<check-within> (parse-expr 'e1) (parse-expr 'e2) (parse-expr 'e3)))
(check-expect (parse-test-case '(check-error e1 e2))
              (make-<check-error> (parse-expr 'e1) (parse-expr 'e2)))

(check-error (parse-test-case '(check-expect))
             (parse-error-msg 'check-expect '(check-expect)))
(check-error (parse-test-case '(check-within))
             (parse-error-msg 'check-within '(check-within)))
(check-error (parse-test-case '(check-error))
             (parse-error-msg 'check-error '(check-error)))

;; Library requires
;; ================

(define (parse-library-require sexp)
  (if (and (list? sexp)
           (= 2 (length sexp))
           (symbol? (first sexp))
           (symbol=? (first sexp) 'require))
      (cond [(string? (second sexp))
             (make-<require-file> (second sexp))]
            [(and (list? (second sexp))
                  (>= (length (second sexp)) 2)
                  (and (symbol? (first (second sexp)))
                       (symbol=? 'lib (first (second sexp))))
                  (andmap string? (rest (second sexp))))
             (make-<require-lib> (rest (second sexp)))]
            [(and (list? (second sexp))
                  (= 3 (length (second sexp)))
                  (and (symbol? (first (second sexp)))
                       (symbol=? 'planet (first (second sexp))))
                  (string? (second (second sexp)))
                  (list? (third (second sexp)))
                  (= 4 (length (third (second sexp))))
                  (string? (first (third (second sexp))))
                  (string? (second (third (second sexp))))
                  (number? (third (third (second sexp))))
                  (number? (fourth (third (second sexp)))))
             (make-<require-planet>
              (second (second sexp))
              (first (third (second sexp)))
              (second (third (second sexp)))
              (third (third (second sexp)))
              (fourth (third (second sexp))))]
            [else
             (parse-error 'parse-require sexp)])
      (parse-error 'parse-require sexp)))

(check-expect (parse-library-require '(require "f"))
              (make-<require-file> "f"))
(check-error (parse-library-require '(require 1))
             (parse-error-msg 'parse-require '(require 1)))
(check-error (parse-library-require '(require f g))
             (parse-error-msg 'parse-require '(require f g)))
(check-expect (parse-library-require '(require (lib "f")))
              (make-<require-lib> (list "f")))
(check-expect (parse-library-require '(require (lib "f" "g")))
              (make-<require-lib> (list "f" "g")))
(check-error (parse-library-require '(require (lib f)))
             (parse-error-msg 'parse-require '(require (lib f))))
(check-expect (parse-library-require 
               '(require (planet "tetris.ss" ("dvanhorn" "tetris.plt" 5 0))))
              (make-<require-planet> "tetris.ss"
                                     "dvanhorn"
                                     "tetris.plt"
                                     5
                                     0))

(generate-report)