;; Advanced Student UnParser

;; 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 printer for
;; Advanced Student syntax.

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

;; Incomplete: case, case/else, quasiquote.

(require "data.scm")

(define (unparse-expr exp)
  (cond [(<begin>? exp)  
         `(begin  ,@(map unparse-expr (<begin>-exprs exp)))]
        [(<begin0>? exp) 
         `(begin0 ,@(map unparse-expr (<begin0>-exprs exp)))]
        [(<set!>? exp)   
         `(set! ,(<identifier>-symbol (<set!>-id exp))
                ,(unparse-expr (<set!>-expr exp)))]
        [(<delay>? exp)  
         `(delay ,(unparse-expr (<delay>-expr exp)))]
        [(<lambda>? exp)
         `(lambda ,(map <identifier>-symbol (<lambda>-ids exp))
            ,(unparse-expr (<lambda>-body exp)))]
        [(<local>? exp) 
         `(local ,(map unparse-definition (<local>-defs exp))
            ,(unparse-expr (<local>-body exp)))]
        [(<letrec>? exp) 
         `(letrec ,(map (lambda (id exp) (list (<identifier>-symbol id)
                                               (unparse-expr exp)))
                        (<letrec>-ids exp)
                        (<letrec>-exprs exp))
            ,(unparse-expr (<letrec>-body exp)))]
        [(<shared>? exp)
         `(shared ,(map (lambda (id exp) (list (<identifier>-symbol id)
                                               (unparse-expr exp)))
                        (<shared>-ids exp)
                        (<shared>-exprs exp))
            ,(unparse-expr (<shared>-body exp)))]
        [(<let>? exp)
         `(let ,(map (lambda (id exp) (list (<identifier>-symbol id)
                                            (unparse-expr exp)))
                     (<let>-ids exp)
                     (<let>-exprs exp))
            ,(unparse-expr (<let>-body exp)))]
        [(<let*>? exp)
         `(let* ,(map (lambda (id exp) (list (<identifier>-symbol id)
                                             (unparse-expr exp)))
                      (<let*>-ids exp)
                      (<let*>-exprs exp))
            ,(unparse-expr (<let*>-body exp)))]
        [(<recur>? exp)
         `(recur ,(<identifier>-symbol (<recur>-name exp))
            ,(map (lambda (id exp) (list (<identifier>-symbol id)
                                         (unparse-expr exp)))
                  (<recur>-ids exp)
                  (<recur>-exprs exp))
            ,(unparse-expr (<recur>-body exp)))]
        [(<application>? exp)
         `(,(unparse-expr (<application>-operator exp))
           ,@(map unparse-expr (<application>-operands exp)))]
        [(<cond>? exp)
         `(cond ,@(map (lambda (q a) (list (unparse-expr q)
                                           (unparse-expr a)))
                       (<cond>-questions exp)
                       (<cond>-answers exp)))]
        [(<cond/else>? exp)
         `(cond ,@(map (lambda (q a) (list (unparse-expr q)
                                           (unparse-expr a)))
                       (<cond/else>-questions exp)
                       (<cond/else>-answers exp))
                (else ,(unparse-expr (<cond/else>-default exp))))]
        [(<case>? exp)
         `(case ,(unparse-expr (<case>-expr exp))
            ,@(map (lambda (cs a) (list (map <identifier>-symbol cs)
                                        (unparse-expr a)))
                   (<case>-choices exp)
                   (<case>-answers exp)))]
        [(<case/else>? exp)
         `(case ,(unparse-expr (<case/else>-expr exp))
            ,@(map (lambda (cs a) (list (map <identifier>-symbol cs)
                                        (unparse-expr a)))
                   (<case/else>-choices exp)
                   (<case/else>-answers exp))
            (else ,(unparse-expr (<case/else>-default exp))))]
        [(<if>? exp) 
         `(if ,(unparse-expr (<if>-test exp))
              ,(unparse-expr (<if>-then exp))
              ,(unparse-expr (<if>-else exp)))]
        [(<when>? exp) 
         `(when ,(unparse-expr (<when>-test exp))
            ,(unparse-expr (<when>-body exp)))]
        [(<unless>? exp)
         `(unless ,(unparse-expr (<unless>-test exp))
            ,(unparse-expr (<unless>-body exp)))]
        [(<and>? exp) 
         `(and ,@(map unparse-expr (<and>-exprs exp)))]
        [(<or>? exp) 
         `(or ,@(map unparse-expr (<or>-exprs exp)))]
        [(<time>? exp) 
         `(time ,(unparse-expr (<time>-expr exp)))]
        [(<identifier>? exp) (<identifier>-symbol exp)]
        [(<quote>? exp) `(quote ,(unparse-quoted (<quote>-body exp)))]
        ;; (<quasiquote>? x)
        [(<number>? exp) (<number>-number exp)]
        [(<empty>? exp) 'empty]
        [(<true>? exp) 'true]
        [(<false>? exp) 'false]
        [(<string>? exp) (<string>-string exp)]
        [(<character>? exp) (<character>-char exp)]))

(define (unparse-quoted qot)
  (cond [(<identifier>? qot) (<identifier>-symbol qot)]
        [(<number>? qot) (<number>-number qot)]
        [(<string>? qot) (<string>-string qot)]
        [(<character>? qot) (<character>-char qot)]
        [(<quoted-list>? qot) (map unparse-quoted (<quoted-list>-bodies qot))]))

(define (unparse-definition def)
  (cond [(<definition-procedure>? def)
         `(define (,(<identifier>-symbol (<definition-procedure>-name def))
                   ,@(map <identifier>-symbol (<definition-procedure>-ids def)))
            ,(unparse-expr (<definition-procedure>-expr def)))]
        [(<definition-value>? def)
         `(define ,(<identifier>-symbol (<definition-value>-id def))
            ,(unparse-expr (<definition-value>-expr def)))]
        [(<definition-struct>? def)
         `(define-struct 
            ,(<identifier>-symbol (<definition-struct>-id def))
            ,(map <identifier>-symbol (<definition-struct>-field-ids def)))]))

(define (unparse-test-case tes)
  (cond [(<check-expect>? tes) 
         `(check-expect ,(unparse-expr (<check-expect>-check tes))
                        ,(unparse-expr (<check-expect>-expect tes)))]
        [(<check-within>? tes) 
         `(check-within ,(unparse-expr (<check-within>-check tes))
                        ,(unparse-expr (<check-within>-expect tes))
                        ,(unparse-expr (<check-within>-delta tes)))]
        [(<check-error>? tes)
         `(check-error ,(unparse-expr (<check-error>-check tes))
                       ,(unparse-expr (<check-error>-message tes)))]))

(define (unparse-library-require lib)
  (cond [(<require-file>? lib) `(require ,(<require-file>-string lib))]
        [(<require-lib>? lib)  `(require (lib ,@(<require-lib>-strings lib)))]
        [(<require-planet>? lib) 
         `(require (planet ,(<require-planet>-file lib)
                           (,(<require-planet>-author lib)
                            ,(<require-planet>-package lib)
                            ,(<require-planet>-major lib) 
                            ,(<require-planet>-minor lib))))]))

(define (unparse-def-or-expr stx)
  (cond [(<definition>? stx)      (unparse-definition stx)]
        [(<expr>? stx)            (unparse-expr stx)]
        [(<test-case>? stx)       (unparse-test-case stx)]
        [(<library-require>? stx) (unparse-library-require stx)]))

(require "parser.ss")

(define id (compose unparse-def-or-expr parse-def-or-expr))
(check-expect (id 1)
              1)
(check-expect (id #\c)
              #\c)
(check-expect (id "f")
              "f")
(check-expect (id '(begin 1 2 3))
              '(begin 1 2 3))
(check-expect (id '(begin0 1 2 3))
              '(begin0 1 2 3))
(check-expect (id '(set! x 1))
              '(set! x 1))
(check-expect (id '(delay x))
              '(delay x))
(check-expect (id '(lambda (x) x))
              '(lambda (x) x))
(check-expect (id '(local [(define x 1)] x))
              '(local [(define x 1)] x))
(check-expect (id '(letrec ((x 1)) x))
              '(letrec ((x 1)) x))
(check-expect (id '(shared ((x 1)) x))
              '(shared ((x 1)) x))
(check-expect (id '(let ((x 1)) x))
              '(let ((x 1)) x))
(check-expect (id '(let* ((x 1)) x))
              '(let* ((x 1)) x))
(check-expect (id '(recur f ((x 1)) x))
              '(recur f ((x 1)) x))
(check-expect (id '(f x))
              '(f x))
(check-expect (id '(cond [true 1]))
              '(cond [true 1]))
(check-expect (id '(cond [true 1] [else 2]))
              '(cond [true 1] [else 2]))
(check-expect (id '(case x [(y) 1]))
              '(case x [(y) 1]))
(check-expect (id '(case x [(y) 1] [else 2]))
              '(case x [(y) 1] [else 2]))
(check-expect (id '(if x y z))
              '(if x y z))
(check-expect (id '(when x y))
              '(when x y))
(check-expect (id '(unless x y))
              '(unless x y))
(check-expect (id '(and x y z))
              '(and x y z))
(check-expect (id '(or x y z))
              '(or x y z))
(check-expect (id '(time x))
              '(time x))
(check-expect (id 'x)
              'x)
(check-expect (id '(quote x))
              '(quote x))
(check-expect (id '(quote quote))
              '(quote quote))
(check-expect (id '(quote ()))
              '(quote ()))
(check-expect (id '(quote "f"))
              '(quote "f"))
(check-expect (id '(quote #\c))
              '(quote #\c))
(check-expect (id '(quote 5))
              '(quote 5))
(check-expect (id '(define x 1))
              '(define x 1))
(check-expect (id '(define (f x) x))
              '(define (f x) x))
(check-expect (id '(define-struct s (x y z)))
              '(define-struct s (x y z)))
(check-expect (id '(check-expect true false))
              '(check-expect true false))
(check-expect (id '(check-within x y z))
              '(check-within x y z))
(check-expect (id '(check-error x y))
              '(check-error x y))
(check-expect (id '(require "f"))
              '(require "f"))
(check-expect (id '(require (lib "f")))
              '(require (lib "f")))
(check-expect (id '(require (planet "tetris.ss" ("dvanhorn" "tetris.plt" 5 0))))
              '(require (planet "tetris.ss" ("dvanhorn" "tetris.plt" 5 0))))

(generate-report)