;; An expval is 
;;   * number, or
;;   * closure

;; A denval is an expval

;; The language:
;;  <expr> = <number>                        ;; a number
;;         | @<number>                       ;; looks up a value in the env
;;         | [<expr>]                        ;; creates a closure (1 arg)
;;         | call(<expr>, <expr>)            ;; applies a closure (1 arg)
;;         | ifzero(<expr>, <expr>, <expr>)  ;; branch
;;         | +(<expr>, <expr>)               ;; add
;;         | -(<expr>, <expr>)               ;; subtract

;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) 
                skip)
    (id (letter (arbno (or letter digit "?")))
        make-symbol)
    (number ((or "" "-" "+") digit (arbno digit))
            make-number)))

(define the-grammar
  '((expression ("*") black-hole-exp)
    (expression (number) lit-exp)
    (expression ("@" number) lookup-exp)
    (expression ("[" expression "]") proc-exp)
    (expression ("call" "(" expression "," expression ")") app-exp)
    (expression ("ifzero" 
		 "(" expression 
		 "," expression 
		 "," expression ")") 
		ifzero-exp)
    (expression ("+" "(" expression "," expression ")") add-exp)
    (expression ("-" "(" expression "," expression ")") subtract-exp)))

(sllgen:make-define-datatypes the-lexical-spec
                              the-grammar)

(define-datatype
  closure closure?
  (a-closure (env environment?)
	     (body expression?)))

(define-datatype type type?
  (number-type)
  (proc-type
    (arg-type type?)
    (result-type type?))
  (tvar-type
    (serial-number integer?)
    (container vector?)))

;;;;;;;;;;;;;;;; top level ;;;;;;;;;;;;;;;;

; typecheck : string -> val
;
; Takes a string respresting concrete syntax and
; infers types while checking it. If it checks, a value
; is returned representing the type, otherwise an error
; is reported.
;
;  (typecheck "5") = _num_
;  (typecheck "[1]") = _(tvar17 -> num)_
;  (typecheck "call([@0], 1)") = _num_
;
(define typecheck
  (lambda (string)
    (type-to-external-form (type-of-expression (scan&parse string) (empty-tenv)))))

; read-eval-print : -> [loops forever]
(define read-eval-print
  (lambda ()
    ((sllgen:make-rep-loop "-->"
			   (lambda (x) (eval-expression x (empty-env)))
                           (sllgen:make-stream-parser
                            the-lexical-spec
                            the-grammar)))))

; run : string -> expval
;
; Takes a string respresting concrete syntax and
; evaluates it, returning the result.
;
;  (run "5") = _5_
;  (run "[1]") = _(a-closure (empty-env) (lit-exp 1))_
;  (run "call([@0], 1)") = _1_
;
(define run
  (lambda (string)
    (eval-expression (scan&parse string) (empty-env))))

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec the-grammar))

;;;;;;;;;;;;;;;; the checker ;;;;;;;;;;;;;;;;

; type-of-expression : expression tenv -> type
(define (type-of-expression exp tenv)
  ;; Obviously, this isn't right, yet:
  (number-type))

;; This isn't right, either
(define (empty-tenv) 'no-tenv-implemented-yet)

;;;;;;;;;;;;;;;; type helper functions ;;;;;;;;;;;;;;;;

(define make-tvar
  (let ((serial-number 0))
    (lambda ()
      (set! serial-number (+ 1 serial-number))
      (tvar-type serial-number (vector '() )))))

(define number-type?
  (lambda (ty)
    (cases type ty
      (number-type () #t)
      (else #f))))

(define proc-type?
  (lambda (ty)
    (cases type ty
      (proc-type (arg-types result-type) #t)
      (else #f))))

(define tvar-type?
  (lambda (ty)
    (cases type ty
      (tvar-type (sn cont) #t)
      (else #f))))

(define proc-type->arg-type
  (lambda (ty)
    (cases type ty
      (proc-type (arg-type result-type) arg-type)
      (else (eopl:error 'proc-type->arg-type
              "Not a proc type: ~s" ty)))))

(define proc-type->result-type
  (lambda (ty)
    (cases type ty
      (proc-type (arg-types result-type) result-type)
      (else (eopl:error 'proc-type->result-type
              "Not a proc type: ~s" ty)))))

(define tvar-type->serial-number
  (lambda (ty)
    (cases type ty
      (tvar-type (sn c) sn)
      (else (eopl:error 'tvar-type->serial-number
              "Not a tvar-type: ~s" ty)))))

(define tvar-type->container
  (lambda (ty)
    (cases type ty
      (tvar-type (sn vec) vec)
      (else (eopl:error 'tvar-type->container
              "Not a tvar-type: ~s" ty)))))

(define tvar->contents
  (lambda (ty)
    (vector-ref (tvar-type->container ty) 0)))

(define tvar-set-contents!
  (lambda (ty val)
    (vector-set! (tvar-type->container ty) 0 val)))

(define tvar-non-empty?
  (lambda (ty)
    (not (null? 
          (vector-ref (tvar-type->container ty) 0)))))

(define type-to-external-form
  (lambda (ty)
    (cases type ty
      (number-type () 'num)
      (proc-type (arg-type result-type)
		 (list
		  (type-to-external-form arg-type)
		  '->
		  (type-to-external-form result-type)))
      (tvar-type (serial-number container) 
		 (if (tvar-non-empty? ty)
		     (type-to-external-form (tvar->contents ty))
		     (string->symbol
		      (string-append
		       "tvar"
		       (number->string serial-number))))))))


;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;

; eval-expression : expression env -> expval
;
; Evaluates an expression in the given environment.
;
;  (eval-expression (lit-exp 5) (empty-env)) = 5
;  (eval-expression (lookup-exp 1) 
;                   (extend-env 42 (extend-env 43 (empty-env)))) = 43
;  (eval-expression (app-exp (proc-exp (lookup-exp 0)) 
;                            (lit-exp 42)) 
;                   (empty-env)) = 42
;
(define eval-expression 
  (lambda (exp env)
    (cases expression exp
      (black-hole-exp () (black-hole))
      (lit-exp (sym) sym)
      (lookup-exp (cn) (apply-env env cn))
      (proc-exp (body) (a-closure env body))
      (app-exp (rator rand)
	       (let ([func (eval-expression rator env)]
		     [arg (eval-expression rand env)])
		 (apply-proc func arg)))
      (ifzero-exp (test then else)
		  (if (zero? (eval-expression test env))
		      (eval-expression then env)
		      (eval-expression else env)))
      (add-exp (a b) (+ (eval-expression a env)
			(eval-expression b env)))
      (subtract-exp (a b) (- (eval-expression a env)
			     (eval-expression b env))))))

; apply-proc : proc expval -> expval
(define (apply-proc func arg)
  (cases closure func
	 (a-closure (env body)
		    (eval-expression
		     body
		     (extend-env
		      arg
		      env)))))

(define (black-hole)
  (black-hole))

;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;

;; Abstract envrionment datatype implementation.

(define (denval? x) 
  (or (number? x) (closure? x)))

(define-datatype environment environment?
  (empty-env-rec)
  (extended-env-rec
    (val denval?)
    (env environment?)))

; empty-env : -> env
(define empty-env
  (lambda ()
    (empty-env-rec)))

; extend-env : denval env -> env 
(define extend-env
  (lambda (val env)
    (extended-env-rec val env)))

; apply-env : env num -> denval
(define apply-env
  (lambda (env cn)
    (cases environment env
      (empty-env-rec ()
        (eopl:error 'apply-env "lookup too deep"))
      (extended-env-rec (val env)
	(if (zero? cn)
            val
            (apply-env env (- cn 1)))))))