#lang pl

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

#| The BNF:
   <TOY> ::= <num>
           | <id>
           | { set! <id> <TOY> }
           | { bind {{ <id> <TOY> } ... } <TOY> <TOY> ... }
           | { bindrec {{ <id> <TOY> } ... } <TOY> <TOY> ... }
           | { fun { <id> ... } <TOY> <TOY> ... }
           | { rfun { <id> ... } <TOY> <TOY> ... }
           | { if <TOY> <TOY> <TOY> }
           | { <TOY> <TOY> ... }
|#

(define-type BINDINGS = (Listof (Listof Symbol)))

;; A matching abstract syntax tree datatype:
(define-type TOY
             [Num Number]
             [Id Symbol]
             [Set Symbol TOY]
             [Bind (Listof Symbol) (Listof TOY) (Listof TOY)]
             [BindRec (Listof Symbol) (Listof TOY) (Listof TOY)]
             [Fun (Listof Symbol) (Listof TOY)]
             [RFun (Listof Symbol) (Listof TOY)]
             [Call TOY (Listof TOY)]
             [If TOY TOY TOY])

(: unique-list? : (Listof Any) -> Boolean)
;; Tests whether a list is unique, guards Bind and Fun values.
(define (unique-list? xs)
  (or (null? xs)
      (and (not (member (first xs) (rest xs)))
           (unique-list? (rest xs)))))

; Parametric types having to end in '-of' is dumb.
(define-type (Perhapsof A)
             [Some A]
             [None])

(: index-of : Symbol (Listof Symbol) -> (Perhapsof Natural))
(define (index-of name names)
  (: loop : (Listof Symbol) Natural -> (Perhapsof Natural))
  (define (loop remaining idx)
    (cond [(null? remaining) (None)]
          [(symbol=? name (first remaining)) (Some idx)]
          [else (loop (rest remaining) (add1 idx))]))
  (loop names 0))

(: find-index : Symbol BINDINGS -> (Perhapsof (List Natural Natural)))
(define (find-index name bindings)
  (: loop : BINDINGS Natural -> (Perhapsof (List Natural Natural)))
  (define (loop rest-bindings binding-idx)
    (cond [(null? rest-bindings) (None)]
          [else
           (let ([name-idx (index-of name (first rest-bindings))])
             (cases name-idx
                    [(Some idx-in-scope) (Some (list binding-idx idx-in-scope))]
                    [(None) (loop (rest rest-bindings) (add1 binding-idx))]))]))
  (loop bindings 0))

(: parse-sexpr : Sexpr -> TOY)
;; parses s-expressions into TOYs
(define (parse-sexpr sexpr)
  (match sexpr
    [(number: n) (Num n)]
    [(symbol: name) (Id name)]
    [(cons 'set! more)
     (match sexpr
       [(list 'set! (symbol: name) new) (Set name (parse-sexpr new))]
       [else (error 'parse-sexpr "bad `set!' syntax in ~s" sexpr)])]
    [(cons (and binder (or 'bind 'bindrec)) more)
     (match sexpr
       [(list _ (list (list (symbol: names) (sexpr: nameds)) ...)
              body0 body ...)
        (if (unique-list? names)
            ((if (eq? 'bind binder) Bind BindRec)
             names
             (map parse-sexpr nameds)
             (map parse-sexpr (cons body0 body)))
            (error 'parse-sexpr "duplicate `~s' names: ~s" binder names))]
       [else (error 'parse-sexpr "bad `~s' syntax in ~s"
                    binder sexpr)])]
    [(cons (and funner (or 'fun 'rfun)) more)
     (match sexpr
       [(list _ (list (symbol: names) ...)
              body0 body ...)
        (if (unique-list? names)
            ((if (eq? 'fun funner) Fun RFun)
             names
             (map parse-sexpr (cons body0 body)))
            (error 'parse-sexpr "duplicate `~s' names: ~s" funner names))]
       [else (error 'parse-sexpr "bad `~s' syntax in ~s"
                    funner sexpr)])]
    [(cons 'if more)
     (match sexpr
       [(list 'if cond then else)
        (If (parse-sexpr cond) (parse-sexpr then) (parse-sexpr else))]
       [else (error 'parse-sexpr "bad `if' syntax in ~s" sexpr)])]
    [(list fun args ...) ; other lists are applications
     (Call (parse-sexpr fun)
           (map parse-sexpr args))]
    [else (error 'parse-sexpr "bad syntax in ~s" 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 = (Listof (Listof (Boxof VAL))))

(define-type VAL
             [BogusV]
             [RktV Any]
             [FunV (Listof Symbol) (ENV -> VAL) ENV Boolean] ; `byref?' flag
             [PrimV ((Listof VAL) -> VAL)])

;; a single bogus value to use wherever needed
(define the-bogus-value (BogusV))

(: extend : (Listof VAL) ENV -> ENV)
;; extends an environment with a new frame (given plain values).
(define (extend names values env)
  (cons (map (inst box VAL) values) env))

(: extend-rec : (Listof (ENV -> VAL)) ENV -> ENV)
;; extends an environment with a new recursive frame (given compiled
;; expressions).
(define (extend-rec compiled-exprs env)
  (define new-boxes
    (map (λ (_) (box the-bogus-value)) compiled-exprs))
  (define new-frame new-boxes)
  (define new-env (cons new-frame env))
  ;; note: no need to check the lengths here, since this is only
  ;; called for `bindrec', and the syntax make it impossible to have
  ;; different lengths
  (for-each (lambda ([boxed-val : (Boxof VAL)] [compiled : (ENV -> VAL)])
              (set-box! boxed-val (compiled new-env)))
            new-boxes compiled-exprs)
  new-env)

(: framerefbox : (Listof (Boxof VAL)) Natural -> (Boxof VAL))
;; Gets you the box at idx in the frame.
(define (framerefbox frame idx)
  (if (null? frame)
      (error 'framerefbox "no binding found for index ~s" idx)
      (if (zero? idx)
          (first frame)
          (framerefbox (rest frame) (sub1 idx)))))

(: envrefbox : ENV Natural Natural -> (Boxof VAL))
;; Gets you the box at (frameidx, keyidx) in an environment.
(define (envrefbox env frameidx keyidx)
  (if (null? env)
      (error 'envrefbox "no binding found for frame index ~s" frameidx)
      (if (zero? frameidx)
          (framerefbox (first env) keyidx)
          (envrefbox (rest env) (sub1 frameidx) keyidx))))

(: unwrap-rktv : VAL -> Any)
;; helper for `racket-func->prim-val': unwrap a RktV wrapper in
;; preparation to be sent to the primitive function
(define (unwrap-rktv x)
  (cases x
         [(RktV v) v]
         [else (error 'racket-func "bad input: ~s" x)]))

(: racket-func->prim-val : Function -> VAL)
;; converts a racket function to a primitive evaluator function which
;; is a PrimV holding a ((Listof VAL) -> VAL) function.  (the
;; resulting function will use the list function as is, and it is the
;; list function's responsibility to throw an error if it's given a
;; bad number of arguments or bad input types.)
(define (racket-func->prim-val racket-func)
  (define list-func (make-untyped-list-function racket-func))
  (PrimV (lambda (args)
           (RktV (list-func (map unwrap-rktv args))))))

;; The global environment has a few primitives:
(: global-environment : (Listof (List Symbol VAL)))
(define global-environment
  (list (list '+ (racket-func->prim-val +))
        (list '- (racket-func->prim-val -))
        (list '* (racket-func->prim-val *))
        (list '/ (racket-func->prim-val /))
        (list '< (racket-func->prim-val <))
        (list '> (racket-func->prim-val >))
        (list '= (racket-func->prim-val =))
        ;; values
        (list 'true (RktV #t))
        (list 'false (RktV #f))))

(: global-lookup : Symbol -> VAL)
(define (global-lookup name)
  (let ([cell (assq name global-environment)])
    (if cell
        (second cell)
        (error 'global-lookup "no binding for ~s" name))))

;;; ==================================================================
;;; Compilation

(: compiler-enabled? : (Boxof Boolean))
;; a global flag that can disable the compiler
(define compiler-enabled? (box #f))

(: compile-body : (Listof TOY) BINDINGS -> (ENV -> VAL))
;; compiles a list of expressions to a single Racket function.
(define (compile-body exprs bin)
  (unless (unbox compiler-enabled?)
    (error 'compile-body "compiler disabled"))
  (let ([compiled-1st (compile (first exprs) bin)]
        [rest (rest exprs)])
    (if (null? rest)
        compiled-1st
        (let ([compiled-rest (compile-body rest bin)])
          (lambda (env)
            (define ignored (compiled-1st env))
            (compiled-rest env))))))

(: compile-get-boxes : (Listof TOY) BINDINGS -> (ENV -> (Listof (Boxof VAL))))
;; utility for applying rfun
(define (compile-get-boxes exprs bin)
  (: compile-getter : TOY -> (ENV -> (Boxof VAL)))
  (define (compile-getter expr)
    (cases expr
           [(Id name)
            (cases (find-index name bin)
                   [(Some location) (λ ([env : ENV])
                                      (envrefbox env (first location) (second location)))]
                   [(None) (if (assq name global-environment)
                               (λ ([_ : ENV]) (error 'call "rfun can't use global ~s" name))
                               (error 'compile-get-boxes "no binding for ~s" name))])]
           [else
            (lambda ([_ : ENV])
              (error 'call "rfun application with a non-identifier ~s"
                     expr))]))
  (unless (unbox compiler-enabled?)
    (error 'compile-get-boxes "compiler disabled"))
  (let ([getters (map compile-getter exprs)])
    (lambda (env)
      (map (lambda ([get-box : (ENV -> (Boxof VAL))]) (get-box env))
           getters))))

(: compile : TOY BINDINGS -> (ENV -> VAL))
;; compiles TOY expressions to Racket functions.
(define (compile expr bin)
  ;; convenient helper for running compiled code
  (: caller : ENV -> ((ENV -> VAL) -> VAL))
  (define (caller env)
    (lambda (compiled) (compiled env)))
  (unless (unbox compiler-enabled?)
    (error 'compile "compiler disabled"))
  (: compile* : TOY -> (ENV -> VAL))
  (define (compile* expr*) (compile expr* bin))
  (cases expr
         [(Num n) (lambda ([env : ENV]) (RktV n))]
         [(Id name)
          (cases (find-index name bin)
                 [(Some location) (λ ([env : ENV]) (unbox (envrefbox env (first location) (second location))))]
                 [(None) (let ([global-val (global-lookup name)])
                           (λ ([_ : ENV]) global-val))])]
         [(Set name new)
          (define compiled-new (compile new bin))
          (cases (find-index name bin)
                 [(Some location)
                  (λ ([env : ENV])
                    (set-box! (envrefbox env (first location) (second location))
                              (compiled-new env))
                    the-bogus-value)]
                 [(None)
                  (let ([_ (global-lookup name)])
                    (λ ([_ : ENV]) (error 'compile "can't set flobal binding for ~s" name)))])]
         [(Bind names exprs bound-body)
          (define compiled-exprs (map compile* exprs))
          (define compiled-body (compile-body bound-body (cons names bin)))
          (lambda ([env : ENV])
            (compiled-body
              (extend (map (caller env) compiled-exprs) env)))]
         [(BindRec names exprs bound-body)
          (: ah : (Listof (Listof Symbol)))
          (define ah (cons names bin))
          (define compiled-exprs (map (λ ([x : TOY]) (compile x ah)) exprs))
          (define compiled-body (compile-body bound-body ah))
          (lambda ([env : ENV])
            (compiled-body (extend-rec compiled-exprs env)))]
         [(Fun names bound-body)
          (define compiled-body (compile-body bound-body (cons names bin)))
          (lambda ([env : ENV]) (FunV names compiled-body env #f))]
         [(RFun names bound-body)
          (define compiled-body (compile-body bound-body (cons names bin)))
          (lambda ([env : ENV]) (FunV names compiled-body env #t))]
         [(Call fun-expr arg-exprs)
          (define compiled-fun (compile fun-expr bin))
          (define compiled-args (map compile* arg-exprs))
          (define compiled-boxes-getter (compile-get-boxes arg-exprs bin))
          (lambda ([env : ENV])
            (define fval (compiled-fun env))
            ;; delay evaluating the arguments
            (define arg-vals (lambda () (map (caller env) compiled-args)))
            (cases fval
                   [(PrimV proc) (proc (arg-vals))]
                   [(FunV names compiled-body fun-env byref?)
                    (compiled-body (if byref?
                                       (cons (compiled-boxes-getter env) fun-env)
                                       (extend (arg-vals) fun-env)))]
                   [else (error 'call "function call with a non-function: ~s"
                                fval)]))]
         [(If cond-expr then-expr else-expr)
          (define compiled-cond (compile cond-expr bin))
          (define compiled-then (compile then-expr bin))
          (define compiled-else (compile else-expr bin))
          (lambda ([env : ENV])
            ((if (cases (compiled-cond env)
                        [(RktV v) v] ; Racket value => use as boolean
                        [else #t]) ; other values are always true
                 compiled-then
                 compiled-else)
             env))]))

(: run : String -> Any)
;; compiles and runs a TOY program contained in a string
(define (run str)
  (set-box! compiler-enabled? #t)
  (let ([compiled (compile (parse str) '(()))])
    (set-box! compiler-enabled? #f)
    (let ([result (compiled '())])
      (cases result
             [(RktV v) v]
             [else (error 'run "the program returned a bad value: ~s"
                          result)]))))

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

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

;; More tests for complete coverage
(test (run "{bind x 5 x}") =error> "bad `bind' syntax")
(test (run "{fun x x}") =error> "bad `fun' syntax")
(test (run "{if x}") =error> "bad `if' syntax")
(test (run "{}") =error> "bad syntax")
(test (run "{bind {{x 5} {x 5}} x}") =error> "duplicate*bind*names")
(test (run "{fun {x x} x}") =error> "duplicate*fun*names")
(test (run "{+ x 1}") =error> "no binding for")
(test (run "{+ 1 {fun {x} x}}") =error> "bad input")
(test (run "{+ 1 {fun {x} x}}") =error> "bad input")
(test (run "{1 2}") =error> "with a non-function")
(test (run "{{fun {x} x}}") =error> "arity mismatch")
(test (run "{if {< 4 5} 6 7}") => 6)
(test (run "{if {< 5 4} 6 7}") => 7)
(test (run "{if + 6 7}") => 6)
(test (run "{fun {x} x}") =error> "returned a bad value")

;; assignment tests
(test (run "{set! {+ x 1} x}") =error> "bad `set!' syntax")
(test (run "{bind {{x 1}} {set! x {+ x 1}} x}") => 2)
(test (run "{set! + 1}") =error> "set")
(test (run "{set! nope 1}") =error> "no binding")

;; `bindrec' tests
(test (run "{bindrec {x 6} x}") =error> "bad `bindrec' syntax")
(test (run "{bindrec {{fact {fun {n}
                              {if {= 0 n}
                                1
                                {* n {fact {- n 1}}}}}}}
              {fact 5}}")
      => 120)

;; tests for multiple expressions and assignment
(test (run "{bind {{make-counter
                     {fun {}
                       {bind {{c 0}}
                         {fun {}
                           {set! c {+ 1 c}}
                           c}}}}}
              {bind {{c1 {make-counter}}
                     {c2 {make-counter}}}
                {* {c1} {c1} {c2} {c1}}}}")
      => 6)
(test (run "{bindrec {{foo {fun {}
                             {set! foo {fun {} 2}}
                             1}}}
              {+ {foo} {* 10 {foo}}}}")
      => 21)

;; `rfun' tests
(test (run "{{rfun {x} x} 4}") =error> "non-identifier")
(test (run "{bind {{swap! {rfun {x y}
                            {bind {{tmp x}}
                              {set! x y}
                              {set! y tmp}}}}
                   {a 1}
                   {b 2}}
              {swap! a b}
              {+ a {* 10 b}}}")
      => 12)

;; test that argument are not evaluated redundantly
(test (run "{{rfun {x} x} {/ 4 0}}") =error> "non-identifier")
(test (run "{5 {/ 6 0}}") =error> "non-function")

(test (index-of 'k '(a b k c)) => (Some 2))
(test (index-of 'k '(a b c)) => (None))
(test (find-index 'k '((a b) (k y) (k z))) => (Some '(1 0)))
(test (find-index 'a '((a b) (k y))) => (Some '(0 0)))
(test (find-index 'q '((a b) (k y))) => (None))

;; test compiler-disabled flag, for complete coverage
;; (these tests must use the functions instead of the toplevel `run',
;; since there is no way to get this error otherwise, this indicates
;; that this error should not occur outside of our code -- it is an
;; internal error check)
(test (compile (Num 1) '(())) =error> "compiler disabled")
(test (compile-body (list (Num 1)) '(())) =error> "compiler disabled")
(test (compile-get-boxes (list (Num 1)) '(())) =error> "compiler disabled")

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