#lang scheme/base

(require (planet "evector.scm" ("soegaard" "evector.plt" 1))
         scheme/list
         scheme/match
         "../syntax/ast-core.ss"
         "../syntax/ast-utils.ss"
         "../runtime/runtime.ss"
         "helpers.ss"
         "hoist.ss")

(provide (all-defined-out))

(define (direct-eval? expr)
  (match expr
    [(struct VarReference (_ (struct Identifier (_ 'eval))))
     (or (not (current-lexically-scoped?))
         (not (bound? 'eval)))]
    [_ #f]))

;; TODO: change this to (hasheqof symbol Identifier) ? to track the loc info?

;; env = (hasheqof symbol #t)

;; current-static-environment : (parameterof env)
(define current-static-environment (make-parameter #hasheq()))

;; (union binding Identifier symbol) [env] -> boolean
(define (bound? x [env (current-static-environment)])
  (hash-ref env (name x) (lambda () #f)))

;; (union binding Identifier symbol) -> symbol
(define (name x)
  (cond
    [(Identifier? x) (Identifier-name x)]
    [(binding? x) (name (binding-id x))]
    [(symbol? x) x]
    [else (error 'name "not a name: ~v~n" x)]))

;; (listof (union binding Identifier symbol)) env -> env
(define (bind xs env)
  (if (null? xs) env (bind (cdr xs) (hash-set env (name (car xs)) #t))))

;; current-lexically-scoped? : (parameterof boolean)
(define current-lexically-scoped? (make-parameter #t))

;; The scope chain, only used in dynamic code.
(define scope-chain (datum->syntax #f 'scope-chain))

;; The variable object, only used in dynamic code.
(define variable-object (datum->syntax #f 'variable-object))

(define current-labels (make-parameter null))

(define enable-return? (make-parameter #f))

;; Identifier * identifier * syntax
(define-struct binding (id syntax init))

;; (any -> boolean : b) any -> (optional b)
(define (cast pred? x)
  (and (pred? x) x))

;; (listof (union symbol Identifier)) [(optional region)] [(listof (union arguments-alias syntax))] -> (listof binding)
(define (make-bindings names [loc #f] [inits (map (lambda (name) #'(void)) names)])
  (let ([ids (for/list ([name names])
               (if (symbol? name)
                   (make-Identifier loc name)
                   name))])
    (map make-binding ids (map Identifier->syntax ids) inits)))

;; (listof binding) syntax -> syntax
(define (with-bindings bindings stx)
  (if (current-lexically-scoped?)
      (with-lexical-bindings bindings stx)
      (with-dynamic-bindings bindings stx)))

(define (with-lexical-bindings bindings stx)
  (with-syntax ([(x ...) (map binding-syntax bindings)]
                [(e ...) (map binding-init bindings)]
                [body stx])
    (syntax/loc stx
      (let ([x e] ...) body))))

(define (with-dynamic-bindings bindings stx [as-variable-object? #f])
  (with-syntax ([scope-chain scope-chain]
                [(prop ...)
                 (map (lambda (binding)
                        (with-syntax ([x (binding-syntax binding)]
                                      [e (binding-init binding)])
                          #'[x e]))
                      bindings)]
                [frame (if as-variable-object? variable-object (car (generate-temporaries '(frame))))]
                [body stx])
    (syntax/loc stx
      (let* ([frame (make-frame (object-table prop ...))]
             [scope-chain (cons frame scope-chain)])
        body))))

;; (or FunctionDeclaration/hoisted FunctionExpression/hoisted) -> boolean
;(define (contains-direct-eval? fun)
;  (and (current-lexically-scoped?)
;       (not (memq 'eval (map (compose Identifier-name car) (static-environment))))
;       (let ([body (if (FunctionDeclaration/hoisted? fun)
;                       (FunctionDeclaration-body fun)
;                       (FunctionExpression-body fun))])
;         (ormap Statement-contains-direct-eval? body))))

;; (listof Statement) -> boolean
(define (contains-direct-eval? body)
  (ormap Statement-contains-direct-eval? body))

;; TODO: tighter analysis-- always #f if we go under a binding of 'eval

(define (Statement-contains-direct-eval? stmt)
  (and stmt
       (match stmt
         [(struct BlockStatement (_ stmts)) (ormap Statement-contains-direct-eval? stmts)]
         [(struct EmptyStatement (_)) #f]
         [(struct ExpressionStatement (_ expr)) (Expression-contains-direct-eval? expr)]
         [(struct IfStatement (_ test cons alt)) (or (Expression-contains-direct-eval? test)
                                                     (Statement-contains-direct-eval? cons)
                                                     (Statement-contains-direct-eval? alt))]
         [(struct DoWhileStatement (_ body test)) (or (Statement-contains-direct-eval? body)
                                                      (Expression-contains-direct-eval? test))]
         [(struct WhileStatement (_ test body)) (or (Expression-contains-direct-eval? test)
                                                    (Statement-contains-direct-eval? body))]
         [(struct ForStatement (_ init test incr body)) (or (and (Expression? init) (Expression-contains-direct-eval? init))
                                                            (and incr (Expression-contains-direct-eval? incr))
                                                            (and body (Expression-contains-direct-eval? body)))]
         [(struct ForInStatement (_ lhs rhs body)) (or (and (Expression? lhs) (Expression-contains-direct-eval? lhs))
                                                       (Expression-contains-direct-eval? rhs)
                                                       (Statement-contains-direct-eval? body))]
         [(struct ContinueStatement (_ label)) #f]
         [(struct BreakStatement (_ label)) #f]
         ;; TODO: optimization-- can we ignore direct eval here, since it can't affect anything afterwards? oh... not in case of exceptions...
         [(struct ReturnStatement (_ expr)) (and expr (Expression-contains-direct-eval? expr))]
         [(struct LetStatement (_ head body)) (or (ormap VariableInitializer-contains-direct-eval? head)
                                                  (Statement-contains-direct-eval? body))]
         [(struct WithStatement (_ ctxt body)) (Expression-contains-direct-eval? ctxt)]
         [(struct SwitchStatement (_ expr cases)) (or (Expression-contains-direct-eval? expr)
                                                      (ormap CaseClause-contains-direct-eval? cases))]
         [(struct LabelledStatement (_ label body)) (Statement-contains-direct-eval? body)]
         [(struct ThrowStatement (_ expr)) (Expression-contains-direct-eval? expr)]
         [(struct TryStatement (_ body catch finally)) (or (Statement-contains-direct-eval? body)
                                                           (ormap CatchClause-contains-direct-eval? catch)
                                                           (and finally (Statement-contains-direct-eval? finally)))])))

(define (optional-Expression-contains-direct-eval? expr?)
  (and expr? (Expression-contains-direct-eval? expr?)))

(define (Expression-contains-direct-eval? expr)
  (match expr
    [(or (? StringLiteral?)
         (? NumericLiteral?)
         (? BooleanLiteral?)
         (? RegexpLiteral?)
         (? NullLiteral?))
     #f]
    [(struct ArrayLiteral (_ elts)) (ormap optional-Expression-contains-direct-eval? elts)]
    [(struct ObjectLiteral (_ props)) (ormap (lambda (prop)
                                               (Expression-contains-direct-eval? (cdr prop)))
                                             props)]
    [(struct ThisReference (_)) #f]
    [(struct VarReference (_ id)) #f]
    [(struct BracketReference (_ container key)) (or (Expression-contains-direct-eval? container)
                                                     (Expression-contains-direct-eval? key))]
    [(struct DotReference (_ container id)) (Expression-contains-direct-eval? container)]
    [(struct NewExpression (_ ctor args)) (or (Expression-contains-direct-eval? ctor)
                                              (ormap Expression-contains-direct-eval? args))]
    [(struct PostfixExpression (_ expr op)) (Expression-contains-direct-eval? expr)]
    [(struct PrefixExpression (_ op expr)) (Expression-contains-direct-eval? expr)]
    [(struct InfixExpression (_ left op right)) (or (Expression-contains-direct-eval? left)
                                                    (Expression-contains-direct-eval? right))]
    [(struct ConditionalExpression (_ test cons alt)) (or (Expression-contains-direct-eval? test)
                                                          (Expression-contains-direct-eval? cons)
                                                          (Expression-contains-direct-eval? alt))]
    [(struct AssignmentExpression (_ lhs op rhs)) (or (Expression-contains-direct-eval? lhs)
                                                      (Expression-contains-direct-eval? rhs))]
    [(struct FunctionExpression/hoisted (_ name args body funs vars)) #f]
    [(struct LetExpression (_ head body)) (or (ormap VariableInitializer-contains-direct-eval? head)
                                              (Expression-contains-direct-eval? body))]
    [(struct CallExpression (_ (struct VarReference (_ (struct Identifier (_ 'eval)))) args)) #t]
    [(struct CallExpression (_ method args)) (or (Expression-contains-direct-eval? method)
                                                 (ormap Expression-contains-direct-eval? args))]
    [(struct ParenExpression (_ expr)) (Expression-contains-direct-eval? expr)]
    [(struct ListExpression (_ exprs)) (ormap Expression-contains-direct-eval? exprs)]))

(define (VariableInitializer-contains-direct-eval? init)
  (match init
    [(struct VariableInitializer (_ id expr))
     (and expr (Expression-contains-direct-eval? expr))]))

(define (CaseClause-contains-direct-eval? clause)
  (match clause
    [(struct CaseClause (_ question answer))
     (or (and question (Expression-contains-direct-eval? question))
         (ormap Statement-contains-direct-eval? answer))]))

(define (CatchClause-contains-direct-eval? clause)
  (match clause
    [(struct CatchClause (_ id body))
     (Statement-contains-direct-eval? body)]))