;;; ==================================================================
;;; Syntax

#| The BNF:
<TOY> ::= <num>
        | <id>
        | { bind    {{ <id> <TOY> }* } <TOY>}
        | { bindrec {{ <id> <TOY> }* } <TOY>}
        | { fun { <id>* } <TOY> }
        | { if <TOY> <TOY> <TOY> }
        | { <TOY> <TOY>* }
|#

;; A matching abstract syntax tree datatype:
(define-type TOY
  [Num     (n number?)]
  [Id      (name symbol?)]
  [Bind    (names unique-names?) (exprs (list-of TOY?)) (body TOY?)]
  [Bindrec (names unique-names?) (exprs (list-of TOY?)) (body TOY?)]
  [Fun     (names unique-names?) (body TOY?)]
  [Call    (fun-expr TOY?) (arg-exprs (list-of TOY?))]
  [If      (cond-expr TOY?) (then-expr TOY?) (else-expr TOY?)])

;; unique-list? : list -> bool
;; Tests whether a list is unique, used to make `unique-names?' below.
(define (unique-list? xs)
  (or (null? xs)
      (and (not (member (first xs) (rest xs)))
           (unique-list? (rest xs)))))

;; unique-names? : any -> bool
;; A predicate that is used to specify a type of unique symbol lists.
(define unique-names? (intersect-of (list-of symbol?) unique-list?))

;; parse-sexpr : s-expr -> TOY
(define (parse-sexpr sexpr)
  (cond
   [(number? sexpr) (Num sexpr)]
   [(symbol? sexpr) (Id sexpr)]
   [(or (not (list? sexpr)) (null? sexpr))
    (error 'parse-sexpr "Bad syntax: ~s" sexpr)]
   [else (case (first sexpr)
           [(bind)
            (if (and (= 3 (length sexpr))
                     (list? (second sexpr))
                     (andmap (lambda (x)
                               (and (list? x) (= 2 (length x))))
                             (second sexpr)))
              (Bind (map first (second sexpr))
                    (map (compose parse-sexpr second) (second sexpr))
                    (parse-sexpr (third sexpr)))
              (error 'parse-sexpr "Bad `bind' syntax: ~s" sexpr))]
           [(bind bindrec)
            (if (and (= 3 (length sexpr))
                     (list? (second sexpr))
                     (andmap (lambda (x)
                               (and (list? x) (= 2 (length x))))
                             (second sexpr)))
              (Bindrec (map first (second sexpr))
                    (map (compose parse-sexpr second) (second sexpr))
                    (parse-sexpr (third sexpr)))
              (error 'parse-sexpr "Bad `bindrec' syntax: ~s" sexpr))]
           [(fun)
            (if (and (= 3 (length sexpr)) (list? (second sexpr)))
              (Fun (second sexpr) (parse-sexpr (third sexpr)))
              (error 'parse-sexpr "Bad `fun' syntax: ~s" sexpr))]
           [(if)
            (if (= 4 (length sexpr))
              (If (parse-sexpr (second sexpr))
                  (parse-sexpr (third sexpr))
                  (parse-sexpr (fourth sexpr)))
              (error 'parse-sexpr "Bad `if' syntax: ~s" sexpr))]
           [else ; other lists are applications
            (Call (parse-sexpr (first sexpr))
                  (map parse-sexpr (rest sexpr)))])]))

;; parse : string -> TOY
;; Parses a string containing an TOY expression to a TOY AST.
(define (parse str)
  (parse-sexpr (string->sexpr str)))

;;; ==================================================================
;;; Values and environments

(define-type ENV
  [EmptyEnv]
  [FrameEnv (frame frame?) (rest ENV?)])

(define-type VAL
  [ScmV  (x any?)]
  [FunV  (names unique-names?) (body TOY?) (env ENV?)]
  [PrimV (prim procedure?)])

;; a frame is an association list of names and values.
(define frame?
  (list-of (lambda (x)
             (and (list? x)
                  (= 2 (length x))
                  (symbol? (first x))
                  (VAL? (second x))))))

;; extend : (list-of symbol) (list-of VAL) ENV -> ENV
;; extends an environment with a new frame.
(define (extend names values env)
  (if (= (length names) (length values))
    (FrameEnv (map list names values) env)
    (error 'extend "arity mismatch for names ~s" names)))

;; lookup : symbol ENV -> (box-of VAL)
;; looks a name in an environment, searching through each frame.
(define (lookup name env)
  (cases env
    [(EmptyEnv) (error 'lookup "no binding for ~s" name)]
    [(FrameEnv frame rest)
     (let ([cell (assq name frame)])
       (if cell
         (box (second cell))
         (lookup name rest)))]))

;; scheme-func->prim-val : (any ... -> any) -> TOY-val
;; converts a scheme function to a primitive evaluator
;; function which is a PrimV holding a ((list-of TOY-val) -> TOY-val)
;; procedure.  (the result procedure doesn't check for types and
;; arity.)
(define (scheme-func->prim-val scheme-func)
  (PrimV (lambda (args)
           (let ([args (map (lambda (a)
                              (cases a
                                [(ScmV x) x]
                                [else (error 'scheme-func
                                             "bad input: ~s" a)]))
                            args)])
             (ScmV (apply scheme-func args))))))

;; The global environment has a few primitives:
(define global-environment
  (FrameEnv (list (list '+ (scheme-func->prim-val +))
                  (list '- (scheme-func->prim-val -))
                  (list '* (scheme-func->prim-val *))
                  (list '/ (scheme-func->prim-val /))
                  (list '< (scheme-func->prim-val <))
                  (list '> (scheme-func->prim-val >))
                  (list '= (scheme-func->prim-val =))
                  ;; values
                  (list 'true  (ScmV #t))
                  (list 'false (ScmV #f)))
            (EmptyEnv)))

;;; ==================================================================
;;; Evaluation

;; eval : TOY env -> VAL
;; evaluates TOY expressions.
(define (eval expr env)
  (cases expr
    [(Num n) (ScmV n)]
    [(Id v) (unbox (lookup v env))]
    [(Bind names exprs bound-body)
     (eval bound-body
           (extend names
                   (map (lambda (e) (eval e env)) exprs)
                   env))]
    [(Bindrec names exprs bound-body)
     (eval bound-body
           (extend names
                   (map (lambda (e) (eval e env)) exprs)
                   env))]
    [(Fun names bound-body)
     (FunV names bound-body env)]
    [(Call fun-expr arg-exprs)
     (let ([fval (eval fun-expr env)]
           [arg-vals (map (lambda (e) (eval e env)) arg-exprs)])
       (cases fval
         [(PrimV proc) (proc arg-vals)]
         [(FunV names body fun-env)
          (eval body (extend names arg-vals fun-env))]
         [else (error 'eval "`call' expects a function, got: ~s"
                      fval)]))]
    [(If cond-expr then-expr else-expr)
     (eval (if (cases (eval cond-expr env)
                 [(ScmV v) v] ; Scheme value => use as boolean
                 [else #t])   ; other values are always true
             then-expr
             else-expr)
           env)]))

;; run : string -> number
;; evaluate a TOY program contained in a string
(define (run str)
  (let ([result (eval (parse str) global-environment)])
    (cases result
      [(ScmV n) n]
      [else (error 'run
                   "evaluation returned a non-number: ~s" result)])))

;;; ==================================================================
;;; Tests

(test 5 (run "{{fun {x} {+ x 1}} 4}"))
(test 4 (run "{bind {{add3 {fun {x} {+ x 3}}}} {add3 1}}"))
(test 7 (run "{bind {{add3 {fun {x} {+ x 3}}}
                     {add1 {fun {x} {+ x 1}}}}
                {bind {{x 3}} {add1 {add3 x}}}}"))
(test 124
      (run "{bind {{identity {fun {x} x}}
                   {foo {fun {x} {+ x 1}}}}
              {{identity foo} 123}}"))
(test 7
      (run "{bind {{x 3}}
              {bind {{f {fun {y} {+ x y}}}}
                {bind {{x 5}}
                  {f 4}}}}"))
(test 124
      (run "{{{fun {x} {x 1}}
              {fun {x} {fun {y} {+ x y}}}}
             123}"))

(test 120
      (run "{bindrec {{fact {fun {n}
                              {if {= 0 n}
                                1
                                {* n {fact {- n 1}}}}}}}
              {fact 5}}"))

;;; ==================================================================