;;; $Id: statement-expression.scm,v 1.5 2006/02/26 16:52:06 leavens Exp $
;;;
;;; <statement> ::= <expression>                        "exp-stmt (exp)"
;;;               | (set! <identifier> <expression>)    "set-stmt (id exp)"
;;; <expression> ::= <identifier>                       "var-exp (id)"
;;;               | <number>                            "num-exp (num)"
;;;               | (begin {<statement>}* <expression>) "begin-exp (stmts exp)"

(module statement-expression (lib "typedscm.ss" "typedscm")

(provide statement? expression? exp-stmt? set-stmt?
         var-exp? num-exp? begin-exp?
         exp-stmt set-stmt var-exp num-exp begin-exp
         exp-stmt->exp set-stmt->id set-stmt->exp
         var-exp->id num-exp->num begin-exp->stmts begin-exp->exp
         parse-statement parse-expression)

;; type predicate
(deftype statement? (type-predicate-for statement))
(deftype expression? (type-predicate-for expression))

;; case testers (discriminators)
(deftype exp-stmt? (-> (statement) boolean))
(deftype set-stmt? (-> (statement) boolean))

(deftype var-exp? (-> (expression) boolean))
(deftype num-exp? (-> (expression) boolean))
(deftype begin-exp? (-> (expression) boolean))

;; constructors
(deftype exp-stmt (-> (expression) statement))
(deftype set-stmt (-> (symbol expression) statement))

(deftype var-exp (-> (symbol) expression))
(deftype num-exp (-> (number) expression))
(deftype begin-exp (-> ((list-of statement) expression) expression))

;; observers 
(deftype exp-stmt->exp (-> (statement) expression))
(deftype set-stmt->id (-> (statement) symbol))
(deftype set-stmt->exp (-> (statement) expression))

(deftype var-exp->id (-> (expression) symbol))
(deftype num-exp->num (-> (expression) number))
(deftype begin-exp->stmts (-> (expression) (list-of statement)))
(deftype begin-exp->exp (-> (expression) expression))

;; parsing/bless input correctness
(deftype parse-statement (-> (datum) statement))

(deftype parse-expression (-> (datum) expression))

(require (lib "all-mod.scm" "lib342"))

(defrep (statement (vector-of datum))
        (expression (vector-of datum)))

(define statement?
  (lambda (d)
    (has-type-trusted
      boolean
      (or (internal-exp-stmt? d)
          (and (internal-set-stmt? d)
               (symbol? (vector-ref d 1))
               (expression? (vector-ref d 2)))))))

(define expression?
  (lambda (d)
    (has-type-trusted
      boolean
      (or (and (internal-var-exp? d)
               (symbol? (vector-ref d 1)))
          (and (internal-num-exp? d)
               (number? (vector-ref d 1)))
          (and (internal-begin-exp? d)
               (all statement? (vector-ref d 1))
               (expression? (vector-ref d 2)))))))

(define exp-stmt?
  (lambda (stmt)
    (if (statement? stmt)
	(internal-exp-stmt? stmt)
	(error "Not a statement:" stmt))))

(deftype internal-exp-stmt? (-> ((vector-of datum)) boolean))
(define internal-exp-stmt?
  (lambda (stmt)
    (and (vector? stmt) (= (vector-length stmt) 2)
         (eq? (vector-ref stmt 0) 'exp-stmt))))

(define set-stmt?
  (lambda (stmt)
    (if (statement? stmt)
	(internal-set-stmt? stmt)
	(error "Not a statement:" stmt))))

(deftype internal-set-stmt? (-> ((vector-of datum)) boolean))
(define internal-set-stmt?
  (lambda (stmt)
    (and (vector? stmt) (= (vector-length stmt) 3)
         (eq? (vector-ref stmt 0) 'set-stmt))))

(define var-exp?
  (lambda (exp)
    (if (expression? exp)
	(internal-var-exp? exp)
	(error "Not an expression:" exp))))

(deftype internal-var-exp? (-> ((vector-of datum)) boolean))
(define internal-var-exp?
  (lambda (exp)
    (and (vector? exp) (= (vector-length exp) 2)
         (eq? (vector-ref exp 0) 'var-exp))))

(define num-exp?
  (lambda (exp)
    (if (expression? exp)
	(internal-num-exp? exp)
	(error "Not an expression:" exp))))

(deftype internal-num-exp? (-> ((vector-of datum)) boolean))
(define internal-num-exp?
  (lambda (exp)
    (and (vector? exp) (= (vector-length exp) 2)
         (eq? (vector-ref exp 0) 'num-exp))))

(define begin-exp?
  (lambda (exp)
    (if (expression? exp)
	(internal-begin-exp? exp)
	(error "Not an expression:" exp))))

(deftype internal-begin-exp? (-> ((vector-of datum)) boolean))
(define internal-begin-exp?
  (lambda (exp)
    (and (vector? exp) (= (vector-length exp) 3)
         (eq? (vector-ref exp 0) 'begin-exp))))

(define exp-stmt
  (lambda (exp)
    (vector 'exp-stmt exp)))

(define set-stmt
  (lambda (id stmt)
    (vector 'set-stmt id stmt)))

(define var-exp
  (lambda (id)
    (vector (has-type datum 'var-exp) id)))

(define num-exp
  (lambda (num)
    (vector (has-type datum 'num-exp) num)))

(define begin-exp
  (lambda (stmts exp)
    (vector (has-type datum 'begin-exp) stmts exp)))

(deftype extract-maker (-> ((-> ((vector-of datum)) boolean) string)
                           (-> ((vector-of datum)) (vector-of datum))))
(define extract-maker
  (lambda (test? name)
    (lambda (x)
      (if (test? x)
          x
          (error (string-append
                  "expecting a(n) "
                  name
                  ", but given:")
                 x)))))

(define exp-stmt->exp
  (lambda (stmt)
    (test-type
      (vector-of datum?)
      (vector-ref ((extract-maker internal-exp-stmt? "exp-stmt") stmt)
                  1))))

(define set-stmt->id
  (lambda (stmt)
    (test-type
      symbol?
      (vector-ref ((extract-maker internal-set-stmt? "set-stmt") stmt)
                  1))))

(define set-stmt->exp
  (lambda (stmt)
    (test-type
      (vector-of datum?)
      (vector-ref ((extract-maker internal-set-stmt? "set-stmt") stmt)
                  2))))

(define var-exp->id
  (lambda (exp)
    (test-type
      symbol?
      (vector-ref ((extract-maker internal-var-exp? "var-exp") exp)
                  1))))

(define num-exp->num
  (lambda (exp)
    (test-type
      number?
      (vector-ref ((extract-maker internal-num-exp? "num-exp") exp)
                  1))))

(define begin-exp->stmts
  (lambda (exp)
    (test-type
      (list-of (vector-of datum?))
      (vector-ref ((extract-maker internal-begin-exp? "begin-exp") exp)
                  1))))

(define begin-exp->exp
  (lambda (exp)
    (test-type
      (vector-of datum?)
      (vector-ref ((extract-maker internal-begin-exp? "begin-exp") exp)
                  2))))

(define parse-statement
  (lambda (d)
    (test-type
      (vector-of datum?)
      (cond
       ((and (list? d) (= (length d) 3) (eq? (car d) 'set!)
             (symbol? (cadr d)))
        (set-stmt (cadr d) (parse-expression (caddr d))))
       (else (exp-stmt (parse-expression d)))))))

(define parse-expression
  (lambda (d)
    (test-type
      (vector-of datum?)
      (cond
       ((symbol? d) (var-exp d))
       ((number? d) (num-exp d))
       ((and (list? d) (>= (length d) 2) (eq? (car d) 'begin))
        (let* ((reversed (reverse (cdr d)))
               (exp (car reversed))
               (stmts (reverse (cdr reversed))))
          (begin-exp (map parse-statement stmts)
                     (parse-expression exp))))
       (else (error "parse-expression: bad syntax:" d))))))

) ; end module