;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;  The LET language

; A trick to make DrScheme show the full details of data created using
; constructors created using define-datatype
(require (only mzscheme print-struct))
(print-struct #t)

;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;

;;; an expressed value is either a number or a boolean.

(define-datatype expval expval?
  (num-val
    (value number?))
  (bool-val
    (boolean boolean?))
  )

;;; extractors:

(define expval->num
  (lambda (v)
    (cases expval v
      (num-val (num) num)
      (else (expval-extractor-error 'num v)))))

(define expval->bool
  (lambda (v)
    (cases expval v
      (bool-val (bool) bool)
      (else (expval-extractor-error 'bool v)))))

(define expval-extractor-error
  (lambda (variant value)
    (eopl:error 'expval-extractors "Looking for a ~s, found ~s"
      variant value)))

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

;;; example of a data type built without define-datatype

; Any implementation of environments, as shown in Section 2.2, will do.
; For example, we could have used define-datatype and cases instead:
;
; (define-datatype environment environment?
;   (empty-env)
;   (extend-env
;     (saved-sym symbol?)
;     (saved-val expval?)
;     (saved-env environment?))
;   )
;
; (define apply-env
;   (lambda (env sym)
;     (cases environment env
;       (empty-env ()
;        (eopl:error 'apply-env "No binding for ~s" sym))
;       (extend-env (saved-sym saved-val saved-env)
;         (if (eq? sym saved-sym)
;           saved-val
;           (apply-env saved-env sym)))
;       )))

(define empty-env
  (lambda ()
    '()))

(define extend-env
  (lambda (saved-sym saved-val saved-env)
    (cond
      ((not (symbol? saved-sym))
       (eopl:error 'extend-env "~s is not a symbol" saved-sym))
      ((not (expval? saved-val))
       (eopl:error 'extend-env "~s is not a value" saved-val))
      ((not (environment? saved-env))
       (eopl:error 'extend-env "~s is not an environment" saved-env))
      (else
       (cons (list saved-sym saved-val) saved-env)))))

(define environment?
  (lambda (x)
    (or (null? x)
        (and (pair? x)
             (list? (car x))
             (= 2 (length (car x)))
             (symbol? (car (car x)))
             (expval? (car (cdr (car x))))
             (environment? (cdr x))))))

(define apply-env
  (lambda (env sym)
    (cond
      ((null? env)
       (eopl:error 'apply-env "No binding for ~s" sym))
      ((eq? sym (car (car env)))
       (car (cdr (car env))))
      (else
       (apply-env (cdr env) sym)))))

;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;

;; init-env : () -> environment

;; (init-env) builds an environment in which i is bound to the
;; expressed value 1, v is bound to the expressed value 5, and x is
;; bound to the expressed value 10.

(define init-env
  (lambda ()
    (extend-env
     'i (num-val 1)
     (extend-env
      'v (num-val 5)
      (extend-env
       'x (num-val 10)
       (empty-env))))))

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

(define the-lexical-spec
  '((whitespace (whitespace) skip)
    (comment ("%" (arbno (not #\newline))) skip)
    (identifier
     (letter (arbno (or letter digit "_" "-" "?")))
     symbol)
    (number (digit (arbno digit)) number)
    (number ("-" digit (arbno digit)) number)
    ))

;;; Use show-the-datatypes (defined below) to show the define-datatype
;;; automatically generated from this grammar.

(define the-grammar
  '((program (expression) a-program)

    (expression (number) const-exp)

    (expression (identifier) var-exp)

    (expression
     ("-" "(" expression "," expression ")")
     diff-exp)

    (expression
     ("zero?" "(" expression ")")
     zero?-exp)

    (expression
     ("if" expression "then" expression "else" expression)
     if-exp)

    (expression
     ("let" identifier "=" expression "in" expression)
     let-exp)

    ))

;;;;;;;;;;;;;;;; sllgen boilerplate ;;;;;;;;;;;;;;;;

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

(define show-the-datatypes
  (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))

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

(define just-scan
  (sllgen:make-string-scanner the-lexical-spec the-grammar))

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

;; value-of-program : program -> expval

(define value-of-program
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (value-of body (init-env))))))

;; value-of : expression * environment -> expval

(define value-of
  (lambda (exp env)
    (cases expression exp

      (const-exp (n) (num-val n))

      (var-exp (x) (apply-env env x))

      (diff-exp (e1 e2)
        (let ((n1 (expval->num (value-of e1 env)))
              (n2 (expval->num (value-of e2 env))))
          (num-val (- n1 n2))))

      (zero?-exp (e1)
        (let ((n1 (expval->num (value-of e1 env))))
          (if (zero? n1)
            (bool-val #t)
            (bool-val #f))))

      (if-exp (e1 e2 e3)
        (if (expval->bool (value-of e1 env))
          (value-of e2 env)
          (value-of e3 env)))

      (let-exp (x e1 e2)
        (let ((v1 (value-of e1 env)))
          (value-of e2
            (extend-env x v1 env))))

      )))

;;;;;;;;;;;;;;;; testing ;;;;;;;;;;;;;;;;

;; run : string -> expval

(define run
  (lambda (string)
    (value-of-program (scan&parse string))))

; A test is a list with three elements: the name of the test (a symbol),
; the program to test (a string), and the desired result (a number or a
; boolean).  The desired result may also be the symbol error, but for
; now we just skip those tests.

(define test->name
  (lambda (test)
    (car test)))

(define test->program
  (lambda (test)
    (car (cdr test))))

(define test->result
  (lambda (test)
    (car (cdr (cdr test)))))

(define result->expval
  (lambda (result)
    (cond
      ((number? result)
       (num-val result))
      ((boolean? result)
       (bool-val result))
      (else
       (eopl:error 'result->expval "Can't convert ~s to expval" result)))))

;; test-one : test -> boolean
; The test-one function returns whether the test succeeded.

(define test-one
  (lambda (test)
    (let ((result (test->result test)))
      (or (eq? result 'error)
          (equal? (run (test->program test))
                  (result->expval result))))))

;; test-list : (list-of test) -> (list-of sym)
; The test-list function returns the names of the tests that failed.

(define test-list
  (lambda (tests)
    (cond
      ((null? tests)
       '())
      ((test-one (car tests))
       (test-list (cdr tests)))
      (else
       (cons (test->name (car tests))
             (test-list (cdr tests)))))))

;; test : () -> (list-of sym)

(define test
  (lambda ()
    (test-list
      '(

        ;; simple arithmetic
        (positive-const "11" 11)
        (negative-const "-33" -33)
        (simple-arith-1 "-(44,33)" 11)

        ;; nested arithmetic
        (nested-arith-left "-(-(44,33),22)" -11)
        (nested-arith-right "-(55, -(22,11))" 44)

        ;; simple variables
        (test-var-1 "x" 10)
        (test-var-2 "-(x,1)" 9)
        (test-var-3 "-(1,x)" -9)

        ;; simple unbound variables
        (test-unbound-var-1 "foo" error)
        (test-unbound-var-2 "-(x,foo)" error)

        ;; simple conditionals
        (if-true "if zero?(0) then 3 else 4" 3)
        (if-false "if zero?(1) then 3 else 4" 4)

        ;; test dynamic typechecking
        (no-bool-to-diff-1 "-(zero?(0),1)" error)
        (no-bool-to-diff-2 "-(1,zero?(0))" error)
        (no-int-to-if "if 1 then 2 else 3" error)

        ;; make sure that the test and both arms get evaluated
        ;; properly.
        (if-eval-test-true "if zero?(-(11,11)) then 3 else 4" 3)
        (if-eval-test-false "if zero?(-(11, 12)) then 3 else 4" 4)

        ;; and make sure the other arm doesn't get evaluated.
        (if-eval-test-true-2 "if zero?(-(11, 11)) then 3 else foo" 3)
        (if-eval-test-false-2 "if zero?(-(11,12)) then foo else 4" 4)

        ;; simple let
        (simple-let-1 "let x = 3 in x" 3)

        ;; make sure the body and rhs get evaluated
        (eval-let-body "let x = 3 in -(x,1)" 2)
        (eval-let-rhs "let x = -(4,1) in -(x,1)" 2)

        ;; check nested let and shadowing
        (simple-nested-let "let x = 3 in let y = 4 in -(x,y)" -1)
        (check-shadowing-in-body "let x = 3 in let x = 4 in x" 4)
        (check-shadowing-in-rhs "let x = 3 in let x = -(x,1) in x" 2)

        ))))