#lang scheme/base

(require (planet "evector.scm" ("soegaard" "evector.plt" 1))
         (except-in srfi/1/list any)
         scheme/match
         "../syntax/ast-core.ss"
         "../syntax/ast-utils.ss"
         "../syntax/token.ss"
         "../syntax/exceptions.ss"
         "../../private/config.ss"
         "../runtime/runtime.ss"
         "../../debug.ss"
         "../syntax/parse.ss"
         "helpers.ss"
         "hoist.ss"
         "lexical-context.ss")

(provide compile-script compile-interaction compile-function-expression with-syntax-errors direct-eval)

;; TODO: is generate-temporaries guaranteed never to be captured?
;;  - perhaps not, because sometimes 'x57 == (generate-temporaries '(x))
;;  - perhaps so, if we always use non-forgeable names (e.g., with an illegal character)
;;  - but be careful about capture with string keys!

;; TODO: optimizations
;;   - don't capture return continuation if it's not used
;;   - remove unnecessary `void' if last statement in function is not an expression statement

(define-syntax-rule (syntax/loc* loc expr)
  (syntax/loc (region->syntax loc)
    expr))

;; loop? : Statement -> boolean
(define (loop? stmt)
  (or (DoWhileStatement? stmt)
      (WhileStatement? stmt)
      (ForStatement? stmt)
      (ForInStatement? stmt)))

;; ===========================================================================
;; COMPILER TOP-LEVEL
;; ===========================================================================

(define (with-syntax-errors thunk)
  (with-handlers ([exn:fail:syntax?
                   (lambda (exn)
                     (let* ([loc (exn:fail:syntax-location exn)]
                            [text (format "~a" (exn:fail:syntax-text exn))]
                            [stxloc (build-syntax (string->symbol text) loc)])
                       (raise-syntax-error 'parse (exn-message exn) stxloc stxloc)))])
    (thunk)))

(define (direct-eval args this scope-chain variable-object)
  (when (null? scope-chain)
    (fprintf (current-error-port) "freak out! scope chain is null~n"))
  (if (null? args)
      (void)
      (let ([script (eval (parameterize ([current-lexically-scoped? #f])
                            (compile-script/function (parse-script (value->string (car args))))))])
        (parameterize ([current-this this])
          (script scope-chain variable-object)))))

;; TODO: change this interface. it's ugly

;; compile-script/function : (listof SourceElement) -> syntax
(define (compile-script/function elts)
  (let-values ([(funs vars body) (hoist-script elts)])
    (parameterize ([current-lexically-scoped? (and (current-lexically-scoped?)
                                                   (not (contains-direct-eval? body)))])
      (let-values ([(definitions new-env) (compile-declarations funs vars)])
        (with-syntax ([(defn ...) definitions]
                      [scope-chain scope-chain]
                      [variable-object variable-object]
                      [(s ...) (parameterize ([current-static-environment new-env])
                                 (map compile-statement body))])
          #'(lambda (scope-chain variable-object)
              (parameterize ([current-completion #f])
                defn ... s ...
                (current-completion))))))))
;  (let*-values ([(funs vars stmts) (hoist-script elts)]
;                [(definitions new-env) (compile-declarations funs vars)])
;    (with-syntax ([(defn ...) definitions]
;                  [scope-chain scope-chain]
;                  [variable-object variable-object]
;                  [(s ...) (parameterize ([current-static-environment new-env])
;                             (map compile-statement stmts))])
;      #'(lambda (scope-chain variable-object)
;          (parameterize ([current-completion #f])
;            defn ... s ...
;            (current-completion))))))

(define (compile-script elts)
  (with-syntax ([function (compile-script/function elts)])
    #'(function (list global-object) global-object)))

;; XXX: this *must* be compiled in dynamic mode, since we don't know if eval will be called

;; compile-interaction : (listof SourceElement) -> syntax
(define (compile-interaction elt)
  (let*-values ([(funs vars stmts) (hoist-script elt)]
                [(definitions new-env) (compile-declarations funs vars)])
    (with-syntax ([(defn ...) definitions]
                  [scope-chain scope-chain]
                  [variable-object variable-object]
                  [(s ...) (parameterize ([current-static-environment new-env])
                             (map compile-statement stmts))]
                  [(previous-completion) (generate-temporaries '(previous-completion))])
      (current-static-environment new-env)
      #'(begin
          (define previous-completion (current-completion))
          (current-completion #f)
          (define scope-chain null)
          (define variable-object global-object)
          defn ... s ...
          (begin0
            (cond
              [(current-completion)
               => (lambda (v)
                    (object-set! global-object "it" v)
                    v)]
              [else #f])
            (current-completion previous-completion))))))

;; compile-function-expression : FunctionExpression -> syntax
(define (compile-function-expression expr)
  (match (hoist-expression expr)
    [(struct FunctionExpression/hoisted (loc name args body funs vars))
     (compile-function loc name args body funs vars)]))

;; compile-declarations : (listof FunctionDeclaration/hoisted) * (listof Identifier)
;;                     -> (listof syntax)
;;                        environment
;; compiles top-level declarations ONLY
(define (compile-declarations funs vars)
  (let* ([fun-ids (map FunctionDeclaration-name funs)]
         [all-ids (append fun-ids vars)]
         [new-env (bind all-ids (current-static-environment))]
         [definitions (with-syntax ([variable-object variable-object]
                                    [(var ...) (map Identifier->syntax all-ids)]
                                    [(var-key ...) (map Identifier->key all-ids)]
                                    [(init-e ...) (append (parameterize ([current-static-environment new-env])
                                                            (map compile-function-declaration funs))
                                                          (map (lambda (var) #'(void)) vars))])
                        (syntax->list #'((define-syntax var
                                           (syntax-id-rules (set!)
                                             [(set! var expr) (object-put! variable-object var-key expr)]
                                             ;; TODO: does this object-get need to be guarded?
                                             [var (object-get variable-object var-key)]))
                                         ...
                                         (set! var init-e) ...)))])
;        (for-each (lambda (defn)
;                    (fprintf (current-error-port) "defining: ~a~n" (syntax->datum defn)))
;                  definitions)
    (values definitions new-env)))

;; ===========================================================================
;; LVALUES
;; ===========================================================================

;; reference-expression? : Expression -> boolean
(define (reference-expression? expr)
  (or (VarReference? expr)
      (BracketReference? expr)
      (DotReference? expr)))

;; compile-deletion : Expression -> syntax
(define (compile-deletion expr)
  (match expr
    [(struct VarReference (loc id))
     (cond
       [(and (current-lexically-scoped?) (not (bound? id)))
        #'(quote true)]
       [(not (current-lexically-scoped?))
        (with-syntax ([scope-chain scope-chain]
                      [key (Identifier->key id)])
          (syntax/loc (region->syntax loc)
            (scope-chain-delete! scope-chain key)))]
       [else
        ;; TODO: static error if 'use lexical scope'
        #'(quote false)])]
    [(struct BracketReference (loc container key))
     (with-syntax ([container-e (compile-expression container)]
                   [key-e (compile-expression key)]
                   [(obj-val) (generate-temporaries '(obj-val))])
       (syntax/loc (region->syntax loc)
         (let ([obj-val (value->object container-e)])
           (object-delete! obj-val key-e))))]
    [(struct DotReference (loc container id))
     (with-syntax ([container-e (compile-expression container)]
                   [key-e (Identifier->key id)]
                   [(obj-val) (generate-temporaries '(obj-val))])
       (syntax/loc (region->syntax loc)
         (let ([obj-val (value->object container-e)])
           (object-delete! obj-val key-e))))]))

;; compile-assignment : Expression * syntax -> syntax
(define (compile-assignment lhs rhs-stx)
  (match lhs
    [(struct VarReference (loc id))
     (debug 'scope-resolution "looking for ~a in ~v" (Identifier-name id) (current-static-environment))
     (cond
       [(and (current-lexically-scoped?) (not (bound? id)))
        (debug 'unbound-reference "~a unbound at ~a" (Identifier-name id) (region->string loc))
        (with-syntax ([key (Identifier->key id)]
                      [rhs-e rhs-stx]
                      [(val) (generate-temporaries '(val))])
          (syntax/loc (region->syntax loc)
            (let ([val rhs-e])
              (object-put! global-object key val)
              val)))]
       [(not (current-lexically-scoped?))
        (with-syntax ([scope-chain scope-chain]
                      [key (Identifier->key id)]
                      [rhs-e rhs-stx])
          (syntax/loc (region->syntax loc)
            (scope-chain-set! scope-chain key rhs-e)))]
       [else
        ;; TODO: static error if 'use lexical scope'
        (with-syntax ([x (Identifier->syntax id)]
                      [(val) (generate-temporaries '(val))]
                      [rhs-e rhs-stx])
          (syntax/loc (region->syntax loc)
            (let ([val rhs-e])
              (set! x val)
              val)))])]
    [(struct BracketReference (loc container key))
     (with-syntax ([container-e (compile-expression container)]
                   [key-e (compile-expression key)]
                   [rhs-e rhs-stx]
                   [(container-val key-val) (generate-temporaries '(container-val key-val))])
       (syntax/loc (region->syntax loc)
         (let* ([container-val (value->object container-e)]
                [key-val key-e])
           (object-set! container-val key-val rhs-e))))]
    [(struct DotReference (loc container id))
     (with-syntax ([container-e (compile-expression container)]
                   [rhs-e rhs-stx]
                   [key-val (Identifier->key id)])
       (syntax/loc (region->syntax loc)
         (let ([container-val (value->object container-e)])
           (object-set! container-val key-val rhs-e))))]
    [_ (raise-syntax-error 'compile "invalid assignment left-hand side" (region->syntax (Term-location lhs)))]))

;; compile-lookup : reference-expression -> syntax
(define (compile-lookup expr)
  (match expr
    ;; TODO: binding forms should still introduce binding arrows under with
    ;;  - add name to static environment
    ;;  - compile ref to (if #f x (dynamic-lookup 'x))
    [(struct VarReference (loc id))
     (debug 'scope-resolution "looking for ~a in ~v" (Identifier-name id) (current-static-environment))
     (cond
       [(and (current-lexically-scoped?) (not (bound? id)))
        (debug 'unbound-reference "~a unbound at ~a" (Identifier-name id) (region->string loc))
        (with-syntax ([stxloc (region->syntax loc)]
                      [key (Identifier->key id)])
          (syntax/loc (region->syntax loc)
            (or (object-get global-object key)
                (raise (make-exn:fail:contract:variable (format "~a is not defined" key)
                                                        (current-continuation-marks)
                                                        (string->symbol key))))))]
       [(not (current-lexically-scoped?))
        (with-syntax ([scope-chain scope-chain]
                      [key (Identifier->key id)])
          (syntax/loc (region->syntax loc)
            (or (scope-chain-get scope-chain key)
                (raise (make-exn:fail:contract:variable (format "~a is not defined" key)
                                                        (current-continuation-marks)
                                                        (string->symbol key))))))]
       [else
        ;; TODO: static error if 'use lexical scope'
        (Identifier->syntax id)])]
    [(struct BracketReference (loc container key))
     (with-syntax ([container-e (compile-expression container)]
                   [key-e (compile-expression key)]
                   [(container-val) (generate-temporaries '(container-val))])
       (syntax/loc (region->syntax loc)
         (let ([container-val (value->object container-e)])
           (or (object-get container-val key-e) (void)))))]
    [(struct DotReference (loc container id))
     (with-syntax ([container-e (compile-expression container)]
                   [key-val (Identifier->key id)])
       (syntax/loc (region->syntax loc)
         (or (object-get container-e key-val) (void))))]))

;; ===========================================================================
;; COMPILER CORE
;; ===========================================================================

(define (compile-function-declaration decl)
  (match decl
    [(struct FunctionDeclaration/hoisted (loc name args body funs vars))
     (compile-function loc name args body funs vars)]))

;; TODO: handle return more gracefully (particularly invalid returns)

(define (compile-function loc name args body funs vars)
  (let ([arity (length args)])
    (with-syntax ([(func-object arg-list args-object) (generate-temporaries '(func-object arg-list args-object))])
      (let ([arg-bindings (make-bindings args loc)]
            [fun-bindings (make-bindings (map FunctionDeclaration-name funs) loc)]
            [var-bindings (make-bindings (cons (make-Identifier loc 'arguments) vars) loc)]
            [name-binding (make-bindings (if name (list name) null) loc)]
            [dynamic? (contains-direct-eval? body)])
;        (fprintf (current-error-port) "contains direct eval? ~a~n" dynamic?)
        (let ([still-lexically-scoped? (and (not dynamic?) (current-lexically-scoped?))]
              [new-static-env (bind arg-bindings
                                (bind fun-bindings
                                  (bind var-bindings
                                    (bind name-binding (current-static-environment)))))]
              [arg-refs (map (lambda (arg)
                               (make-VarReference (Term-location arg) arg))
                             args)]
              [arguments-ref (make-VarReference loc (make-Identifier loc 'arguments))]
              [all-local-bindings (delete-duplicates (append arg-bindings fun-bindings var-bindings)
                                                     (lambda (b1 b2)
                                                       (Identifier=? (binding-id b1) (binding-id b2))))])
          (with-syntax ([return (datum->syntax #f 'return)]
                        [(s ...) (parameterize ([enable-return? #t]
                                                [current-static-environment new-static-env]
                                                [current-lexically-scoped? still-lexically-scoped?])
                                   (map compile-statement body))]
                        [set-arguments-object!
                         (parameterize ([current-static-environment new-static-env]
                                        [current-lexically-scoped? still-lexically-scoped?])
                           (with-syntax ([(getter ...) (map (lambda (arg-ref)
                                                              #`(lambda ()
                                                                  #,(compile-lookup arg-ref)))
                                                            arg-refs)]
                                         [(setter ...) (map (lambda (arg-ref)
                                                              (with-syntax ([v (car (generate-temporaries '(v)))])
                                                                #`(lambda (v)
                                                                    #,(compile-assignment arg-ref #'v))))
                                                            arg-refs)])
                             (compile-assignment arguments-ref
                                                 #'(build-arguments-object func-object
                                                                           (list (cons getter setter) ...)
                                                                           arg-list))))]
                        [set-arguments!
                         (parameterize ([current-static-environment new-static-env]
                                        [current-lexically-scoped? still-lexically-scoped?])
                           (with-syntax ([(rhs ...) (map (lambda (arg-ref)
                                                           (with-syntax ([set-undefined! (compile-assignment arg-ref #'(void))]
                                                                         [set-next! (compile-assignment arg-ref #'(car arg-list))])
                                                             #'(if (null? arg-list)
                                                                   (begin set-undefined! '())
                                                                   (begin set-next! (cdr arg-list)))))
                                                         arg-refs)])
                             #'(let* ([arg-list rhs] ...)
                                 (void))))]
                        [(set-nested-func! ...)
                         (parameterize ([current-static-environment new-static-env]
                                        [current-lexically-scoped? still-lexically-scoped?])
                           (map (lambda (fun)
                                  (compile-assignment (make-VarReference (Term-location fun) (FunctionDeclaration-name fun))
                                                      (compile-function-declaration fun)))
                                funs))])
            (let ([block-stx (syntax/loc (region->syntax loc)
                               (begin
                                 set-arguments-object!
                                 set-arguments!
                                 set-nested-func! ...
                                 (parameterize ([current-completion #f])
                                   (let/ec return
                                     s ...
                                     (void)))))])
              (with-syntax ([body (if (or dynamic? (not (current-lexically-scoped?)))
                                      (dynamic-code (with-dynamic-bindings all-local-bindings block-stx #t) loc)
                                      (with-lexical-bindings all-local-bindings block-stx))]
                            [arity arity])
                (if name
                    (with-syntax ([set-f! (parameterize ([current-static-environment new-static-env])
                                            (compile-assignment (make-VarReference loc name)
                                                                #'func-object))])
                      (with-bindings name-binding
                       (syntax/loc (region->syntax loc)
                         (letrec ([func-object (build-function arity (lambda arg-list body))])
                           set-f!
                           func-object))))
                    (syntax/loc (region->syntax loc)
                      (letrec ([func-object (build-function arity (lambda arg-list body))])
                        func-object)))))))))))

(define (reify-environment loc)
  (let ([all-ids (for/list ([name (in-hash-keys (current-static-environment))])
                   (make-Identifier loc name))])
    (values (map (lambda (id)
		   (Identifier->syntax id loc))
		 all-ids)
	    (map (lambda (id)
		   (Identifier->syntax id #f))
		 all-ids)
	    (map Identifier->key all-ids))))

(define (dynamic-code body-stx [loc #f] [extend-scope-chain (lambda (scope-chain) scope-chain)] [shadow-loc #f])
  (with-syntax ([scope-chain scope-chain]
                [body-e body-stx])
    (if (not (current-lexically-scoped?))
        (with-syntax ([scope-e (extend-scope-chain #'scope-chain)])
          (syntax/loc (region->syntax loc)
            (let ([scope-chain scope-e])
              body-e)))
        (let-values ([(shadow-ids invisible-ids names) (reify-environment shadow-loc)])
          (with-syntax ([(shadow-x ...) shadow-ids] ;; to intercept the binding arrows in DrScheme
                        [(x ...) invisible-ids]
                        [(x-name ...) names])
            (with-syntax ([scope-e (extend-scope-chain
                                    #'(list (make-frame
                                             (object-table
                                              [x-name (lambda () x) (lambda (v) (set! x v) v) ()]
                                              ...))
                                            global-object))])
              (syntax/loc (region->syntax loc)
                (let ([scope-chain scope-e])
                  (let-syntax ([shadow-x (syntax-id-rules (set!) ;; XXX: is this code dead?
                                           [(set! shadow-x expr) (scope-chain-set! scope-chain x-name expr)]
                                           [shadow-x (or (scope-chain-get scope-chain x-name)
                                                         (raise (make-exn:fail:contract:variable ;; XXX: there's no such exception type!
                                                                 (format "~a is not defined" x-name)
                                                                 (current-continuation-marks)
                                                                 (string->syntax x-name))))])]
                               ...)
                    body-e)))))))))

(define (compile-statement stmt)
  (match stmt
    [(struct BlockStatement/hoisted (loc stmts funs vars))
     (let ([var-bindings (make-bindings vars loc)]
           [fun-bindings (make-bindings funs loc)])
       (let ([new-static-env (bind var-bindings
                               (bind fun-bindings (current-static-environment)))])
         (with-syntax ([(f ...) (map binding-syntax fun-bindings)]
                       [(fe ...) (parameterize ([current-static-environment new-static-env])
                                   (map compile-function-declaration funs))]
                       [(s ...) (parameterize ([current-static-environment new-static-env])
                                  (map compile-statement stmts))])
           (with-bindings var-bindings
             (with-bindings fun-bindings
               (syntax/loc (region->syntax loc)
                 (begin
                   (set! f fe) ...
                   s ...
                   (current-completion))))))))]
    [(struct EmptyStatement (loc))
     (syntax/loc* loc
       #f)]
    [(struct ExpressionStatement (loc expr))
     (with-syntax ([e (compile-expression expr)])
       (syntax/loc* loc
         (complete! e)))]
    ;; TODO: test IfStatement
    [(struct IfStatement (loc test consequent alternate))
     (with-syntax ([test-e (compile-expression test)]
                   [consequent-s (compile-statement consequent)]
                   [alternate-s (if alternate (compile-statement alternate) #'#f)])
       (syntax/loc* loc
         (if (true-value? test-e)
             consequent-s
             alternate-s)))]
    ;; TODO: test loops
    [(? loop?)
     (with-syntax ([(break continue) (generate-temporaries '(break continue))])
       (parameterize ([current-labels (cons (list #f #'break #'continue)
                                            (current-labels))])
         (compile-loop stmt #'break #'continue)))]
    ;; TODO: test ContinueStatement
    [(struct ContinueStatement (loc #f))
     (cond
       [(ormap (lambda (tuple)
                 (and (pair? (cddr tuple))
                      (caddr tuple)))
               (current-labels))
        => (lambda (continue-id)
             (with-syntax ([continue continue-id])
               (syntax/loc* loc
                 (continue #f))))]
       [else (let ([stxloc (build-syntax 'continue loc)])
               (raise-syntax-error 'continue "invalid continue" stxloc stxloc))])]
    [(struct ContinueStatement (loc label))
     (cond
       [(null? (current-labels))
        (raise-syntax-error 'continue "invalid continue" (build-syntax 'continue loc))]
       [(assq (Identifier-name label) (current-labels))
        => (lambda (tuple)
             (if (pair? (cddr tuple))
                 (with-syntax ([continue (caddr tuple)])
                   (syntax/loc* loc
                     (continue #f)))
                 (raise-syntax-error 'continue "invalid label" (Identifier->syntax label))))]
       [else (raise-syntax-error 'continue "invalid label" (Identifier->syntax label))])]
    ;; TODO: test BreakStatement
    [(struct BreakStatement (loc #f))
     (when (null? (current-labels))
       (let ([stxloc (build-syntax 'break loc)])
         (raise-syntax-error 'break "invalid break" stxloc stxloc)))
     (with-syntax ([break (cadar (current-labels))])
       (syntax/loc* loc
         (break (current-completion))))]
    [(struct BreakStatement (loc label))
     (cond
       [(null? (current-labels))
        (raise-syntax-error 'break "invalid break" (build-syntax 'break loc))]
       [(assq (Identifier-name label) (current-labels))
        => (lambda (tuple)
             (with-syntax ([break (cadr tuple)])
               (syntax/loc* loc
                 (break (current-completion)))))]
       [else (raise-syntax-error 'break "invalid label" (Identifier->syntax label))])]
    [(struct ReturnStatement (loc value))
     (unless (enable-return?)
       (let ([stxloc (build-syntax 'return loc)])
         (raise-syntax-error 'return "invalid return" stxloc stxloc)))
     (with-syntax ([return (datum->syntax #f 'return)]
                   [e (if value
                          (compile-expression value)
                          #'(void))])
       (syntax/loc* loc
         (return e)))]
    [(struct LetStatement (loc bindings body))
     (let ([var-bindings (make-bindings (map VariableInitializer-id bindings)
                                        loc
                                        (map (compose compile-optional-expression VariableInitializer-init) bindings))])
       (with-syntax ([body (parameterize ([current-static-environment (bind var-bindings (current-static-environment))])
                             (compile-statement body))])
         (with-bindings var-bindings
           (syntax/loc (region->syntax loc) body))))]
    [(struct WithStatement (loc object body))
     (let* ([body-stx (parameterize ([current-static-environment #hasheq()]
                                     [current-lexically-scoped? #f])
                        (compile-statement body))]
            [object-stx (compile-expression object)]
            [extend-scope-chain (lambda (scope-chain)
                                  (with-syntax ([scope-chain scope-chain]
                                                [object-e object-stx])
                                    #'(cons object-e scope-chain)))])
       (dynamic-code body-stx loc extend-scope-chain (Term-location object)))]
    ;; TODO: test SwitchStatement
    ;; TODO: what comparison is used on the values? any dynamic dispatch there?
    [(struct SwitchStatement (loc expr (list (struct CaseClause (_ qs as)) ...)))
     (with-syntax ([e (compile-expression expr)]
                   [(x v break falling-through?) (generate-temporaries '(x v break falling-through?))])
       (with-syntax ([(q ...) (map (lambda (q)
                                     (if q
                                         (with-syntax ([test-e (compile-expression q)])
                                           #'(lambda (x)
                                               (equal? x test-e)))
                                         #'(lambda (x) #t)))
                                   qs)])
         (parameterize ([current-labels (cons (list #f #'break) (current-labels))])
           (with-syntax ([((a ...) ...) (map (lambda (stmts)
                                               (map compile-statement stmts))
                                             as)])
             (syntax/loc* loc
               (let ([v e])
                 (let/ec break
                   (let ([falling-through? #f])
                     (when (or falling-through? (q v))
                       (set! falling-through? #t)
                       a ...)
                     ...
                     (current-completion)))))))))]
    ;; TODO: test LabelledStatement
    [(struct LabelledStatement (loc label (? loop? loop)))
     (let ([label-name (Identifier-name label)])
       (with-syntax ([(break continue) (generate-temporaries '(break continue))])
         (parameterize ([current-labels (cons (list label-name #'break #'continue)
                                              (current-labels))])
           (compile-loop loop #'break #'continue))))]
    [(struct LabelledStatement (loc label statement))
     (let ([label-name (Identifier-name label)])
       (with-syntax ([(break) (generate-temporaries '(break))])
         (parameterize ([current-labels (cons (list label-name #'break)
                                              (current-labels))])
           (with-syntax ([s (compile-statement statement)])
             (syntax/loc* loc
               (let/ec break s))))))]
    ;; TODO: test ThrowStatement
    [(struct ThrowStatement (loc value))
     (with-syntax ([stxloc (region->syntax loc)]
                   [e (compile-expression value)])
       (syntax/loc* loc
         (raise-runtime-exception stxloc e)))]
    ;; TODO: test TryStatement
    ;; TODO: add conditions to CatchClause ast and compile that too
    ;; TODO: need an error for try with no catch or finally
    ;; TODO: handle try/finally with return in finally
    [(struct TryStatement (loc body catches finally))
     (with-syntax ([body-s (compile-statement body)]
                   [(catch-e ...) (map compile-catch-clause catches)])
       (with-syntax ([try-catch #'(with-handlers ([exn:runtime? catch-e]
                                                  ...)
                                    body-s)])
         (if finally
             (with-syntax ([finally-s (compile-statement finally)])
               (syntax/loc* loc
                 (begin (dynamic-wind
                         void
                         (lambda () try-catch)
                         (lambda () finally-s))
                        (current-completion))))
             (syntax/loc* loc try-catch))))]
    ))

(define (compile-catch-clause clause)
  (match clause
    [(struct CatchClause (loc exn catch))
     (with-syntax ([exn-value (car (generate-temporaries '(exn-value)))])
       (let ([var-bindings (make-bindings (list exn)
                                          (Term-location exn)
                                          (list
                                           (syntax/loc (region->syntax loc)
                                             (exn:runtime-value exn-value))))])
         (with-syntax ([body (with-bindings var-bindings
                               (parameterize ([current-static-environment (bind var-bindings (current-static-environment))])
                                 (compile-statement catch)))])
           (syntax/loc (region->syntax loc)
             (lambda (exn-value) body)))))]))

;; TODO: test loops
(define (compile-loop stmt break-id continue-id)
  (match stmt
    [(struct DoWhileStatement (loc body test))
     (with-syntax ([body-s (compile-statement body)]
                   [test-e (compile-expression test)]
                   [break break-id]
                   [continue continue-id])
       (syntax/loc* loc
         (let/ec break
           (let loop ()
             (let/ec continue body-s)
             (if (true-value? test-e)
                 (loop)
                 (current-completion))))))]
    [(struct WhileStatement (loc test body))
     (with-syntax ([test-e (compile-expression test)]
                   [body-s (compile-statement body)]
                   [break break-id]
                   [continue continue-id])
       (syntax/loc* loc
         (let/ec break
           (let loop ()
             (if (true-value? test-e)
                 (begin (let/ec continue body-s)
                        (loop))
                 (current-completion))))))]
    [(struct ForStatement (loc init test incr body))
     (with-syntax ([init-e (if init
                               (compile-expression init)
                               #'(void))]
                   [test-e (if test
                               (compile-expression test)
                               #'(quote true))]
                   [incr-e (if incr
                               (compile-expression incr)
                               #'(void))]
                   [body-s (compile-statement body)]
                   [break break-id]
                   [continue continue-id]
                   [(loop) (generate-temporaries '(loop))])
       (syntax/loc* loc
         (begin
           init-e
           (let/ec break
             (let loop ()
               (if (true-value? test-e)
                   (begin (let/ec continue body-s)
                          incr-e
                          (loop))
                   (current-completion)))))))]
    [(struct ForInStatement (loc lhs container body))
     (with-syntax ([(object next-key key) (generate-temporaries '(object next-key key))])
       (with-syntax ([container-e (compile-expression container)]
                     [update (compile-assignment lhs #'key)]
                     [body-s (compile-statement body)]
                     [break break-id]
                     [continue continue-id])
         (syntax/loc (region->syntax loc)
           (let/ec break
             (let* ([object container-e]
                    [next-key (object-keys-stream object)])
               (let loop ()
                 (let ([key (next-key)])
                   (if key
                       (begin
                         update
                         (let/ec continue body-s)
                         (loop))
                       (current-completion)))))))))]
    ))

(define (field-reference? x)
  (or (BracketReference? x)
      (DotReference? x)))

(define (compile-optional-expression expr)
  (if expr (compile-expression expr) #'(void)))

;; TODO: test cases for all expression forms
(define (compile-expression expr)
  (match expr
    [(struct StringLiteral (loc value))
     (build-syntax value loc)]
    [(struct NumericLiteral (loc value))
     (build-syntax value loc)]
    [(struct BooleanLiteral (loc value))
     (if value
         (syntax/loc* loc 'true)
         (syntax/loc* loc 'false))]
    [(struct NullLiteral (loc))
     (syntax/loc* loc '())]
    [(struct RegexpLiteral (loc pattern global? case-insensitive?))
     (begin (printf "expression not compiled: ~v~n" expr)
            #'"<<regular expression>>")]
    [(struct ArrayLiteral (loc elts))
     (with-syntax ([(e ...) (map compile-expression elts)])
       (syntax/loc* loc
         (build-array (evector e ...))))]
    [(struct ObjectLiteral (loc properties))
     (let ([names (map (lambda (prop)
                         (let ([name (car prop)])
                           (cond
                             [(NumericLiteral? name) (NumericLiteral-value name)]
                             [(StringLiteral? name) (StringLiteral-value name)]
                             [(Identifier? name) (Identifier->key name)])))
                       properties)]
           [values (map cdr properties)])
       (with-syntax ([(key ...) names]
                     [(e ...) (map compile-expression values)])
         (syntax/loc* loc
           (build-object
            (object-table [key e] ...)))))]
    [(struct ThisReference (loc))
     (syntax/loc (region->syntax loc)
       (current-this))]
    [(? reference-expression?)
     (compile-lookup expr)]
    [(struct NewExpression (loc constructor args))
     (with-syntax ([stxloc (region->syntax loc)]
                   [constructor-e (compile-expression constructor)]
                   [(e ...) (map compile-expression args)]
                   [(ctor) (generate-temporaries '(ctor))])
       (syntax/loc* loc
         (let ([ctor constructor-e])
           (unless (object? ctor)
             (raise-runtime-type-error stxloc "constructor" ctor))
           ((object-construct ctor) e ...))))]
    [(struct PostfixExpression (loc operand op))
     (with-syntax ([op-e (if (eq? op '++) #'js:+ #'js:-)]
                   [operand-e (compile-expression operand)]
                   [update (compile-expression (make-AssignmentExpression loc
                                                                          operand
                                                                          (if (eq? op '++) '+= '-=)
                                                                          (make-NumericLiteral loc 1)))]
                   [(v) (generate-temporaries '(v))])
       (syntax/loc (region->syntax loc)
         (let ([v (value->number operand-e)])
           update
           v)))]
    [(struct PrefixExpression (loc op operand))
     (cond
       [(memq op '(++ --))
        (let ([op (if (eq? op '++) '+= '-=)])
          (compile-expression
           (make-AssignmentExpression loc operand op (make-NumericLiteral loc 1))))]
       [(eq? op 'delete)
        (compile-deletion operand)]
       [else
        (with-syntax ([op-e (operator->syntax op)]
                      [operand-e (compile-expression operand)])
          (syntax/loc* loc
            (op-e operand-e)))])]
    [(struct InfixExpression (loc left '&& right))
     (with-syntax ([left-e (compile-expression left)]
                   [right-e (compile-expression right)])
       (syntax/loc* loc
         (if (true-value? left-e) right-e 'false)))]
    [(struct InfixExpression (loc left '\|\| right))
     (with-syntax ([left-e (compile-expression left)]
                   [right-e (compile-expression right)]
                   [(tmp) (generate-temporaries '(tmp))])
       (syntax/loc* loc
         (let ([tmp left-e])
           (if (true-value? tmp) tmp right-e))))]
    [(struct InfixExpression (loc left op right))
     (with-syntax ([left-e (compile-expression left)]
                   [op-e (operator->syntax op)]
                   [right-e (compile-expression right)])
       (syntax/loc* loc
         (op-e left-e right-e)))]
    [(struct ConditionalExpression (loc test consequent alternate))
     (with-syntax ([test-e (compile-expression test)]
                   [consequent-e (compile-expression consequent)]
                   [alternate-e (compile-expression alternate)])
       (syntax/loc* loc
         (if test-e consequent-e alternate-e)))]
    [(struct AssignmentExpression (loc left '= right))
     (compile-assignment left (compile-expression right))]
    [(struct AssignmentExpression (loc left op right))
     (compile-expression
      (make-AssignmentExpression loc
                                 left
                                 '=
                                 (make-InfixExpression (Term-location right)
                                                       left
                                                       (assignment-operator->infix-operator op)
                                                       right)))]
    [(struct FunctionExpression/hoisted (loc name args body funs vars))
     (compile-function loc name args body funs vars)]
    [(struct LetExpression (loc bindings body))
     (let ([var-bindings (make-bindings (map VariableInitializer-id bindings)
                                        loc
                                        (map (compose compile-expression VariableInitializer-init) bindings))])
       (with-syntax ([body (parameterize ([current-static-environment (bind var-bindings (current-static-environment))])
                             (compile-expression body))])
         (with-bindings var-bindings
           (syntax/loc (region->syntax loc) body))))]
    ;; TODO: inherit environment if definitely a call to `eval' (10.2.2)
    [(struct CallExpression (loc (and method (struct BracketReference (_ container key))) args))
     (with-syntax ([stxloc (region->syntax loc)]
                   [container-e (compile-expression container)]
                   [key-e (compile-expression key)]
                   [(container-val key-val function-val) (generate-temporaries '(container-val key-val function-val))]
                   [(arg-e ...) (map compile-expression args)]
                   [(arg-val ...) (generate-temporaries args)])
       (syntax/loc (region->syntax loc)
         (let* ([container-val container-e]
                [key-val key-e]
                [function-val (object-get container-val key-val)]
                [arg-val arg-e] ...)
           (parameterize ([current-this container-val])
             ;; TODO: what if there is no method?!
             (call function-val
                   (list arg-val ...)
                   (lambda (str1 str2)
                     (raise-runtime-type-error stxloc str1 str2)))))))]
    [(struct CallExpression (loc (struct DotReference (_ container id)) args))
     (with-syntax ([stxloc (region->syntax loc)]
                   [container-e (compile-expression container)]
                   [key-val (Identifier->key id)]
                   [(container-val function-val) (generate-temporaries '(container-val function-val))]
                   [(arg-e ...) (map compile-expression args)]
                   [(arg-val ...) (generate-temporaries args)])
       (syntax/loc (region->syntax loc)
         (let* ([container-val container-e]
                [function-val (object-get container-val key-val)]
                [arg-val arg-e] ...)
           (parameterize ([current-this container-val])
             ;; TODO: what if there is no method?!
             (call function-val
                   (list arg-val ...)
                   (lambda (str1 str2)
                     (raise-runtime-type-error stxloc str1 str2)))))))]
    [(struct CallExpression (loc (? direct-eval? function) args))
;     (fprintf (current-error-port) "compiler: it's a direct eval~n")
     (with-syntax ([(arg-e ...) (map compile-expression args)]
                   [scope-chain scope-chain]
                   [variable-object variable-object]
                   [stxloc (region->syntax loc)]
                   [(function-val arg-val ...) (generate-temporaries (cons 'function-val args))])
       (syntax/loc (region->syntax loc)
         (if (original-eval?)
             (direct-eval (list arg-e ...)
                          (current-this)
                          scope-chain
                          variable-object)
             (let ([function-val (object-get global-object "eval")]
                   [arg-val arg-e] ...)
               (parameterize ([current-this global-object])
                 (call function-val
                       (list arg-val ...)
                       (lambda (str1 str2)
                         (raise-runtime-type-error stxloc str1 str2))))))))]
    [(struct CallExpression (loc function args))
     (with-syntax ([stxloc (region->syntax loc)]
                   [function-e (compile-expression function)]
                   [(arg-e ...) (map compile-expression args)]
                   [(function-val arg-val ...) (generate-temporaries (cons 'function-val args))])
       (syntax/loc (region->syntax loc)
         (let ([function-val function-e]
               [arg-val arg-e] ...)
           (parameterize ([current-this global-object])
             (call function-val
                   (list arg-val ...)
                   (lambda (str1 str2)
                     (raise-runtime-type-error stxloc str1 str2)))))))]
    [(struct ParenExpression (loc expr))
     (compile-expression expr)]
    [(struct ListExpression (loc (list)))
     #'(void)]
    [(struct ListExpression (loc exprs))
     (with-syntax ([(e ...) (map compile-expression exprs)])
       (syntax/loc* loc
         (begin e ...)))]
    ))