#lang scheme/base

(require (planet "evector.scm" ("soegaard" "evector.plt" 1))
         srfi/13/string
         (except-in scheme/list empty)
         scheme/match
         scheme/math
         "../../debug.ss"
         "../syntax/regexps.ss"
         "eval.ss"
         "exceptions.ss"
         "value.ss"
         "runtime.ss")

;; TODO: abstract out the conveniences like install-properties! into a separate module
(provide install-standard-library! install-properties! reset-global-object! reset-primitive-constructors!)

(define (object-descriptor object)
  (format "[object ~a]" (object-class object)))

(define js:print
  (build-function 1
    (lambda (args)
      (let ([print1 (lambda (x)
                      (display (value->string x)))]
            [args (evector->list args)])
        (unless (null? args)
          (print1 (car args))
          (for-each (lambda (arg)
                      (display " ")
                      (print1 arg))
                    (cdr args)))
        (newline)))))

(define js:parseInt
  (build-function 2
    (lambda (args)
      (let ([string (if (>= (evector-length args) 1)
                        (evector-ref args 0)
                        (void))]
            [radix (if (>= (evector-length args) 2)
                       (evector-ref args 1)
                       (void))])
        (let* ([s (string-trim (value->string string) char-whitespace?)]
               [r (value->int32 radix)]
               [sign (if (char=? (string-ref s 0) #\-)
                         (begin (set! s (substring s 1)) -1)
                         1)])
          (if (or (and (not (zero? r)) (< r 2))
                  (> r 36))
              +nan.0
              (let ([r (cond
                         [(or (string-prefix? "0x" s) (string-prefix? "0X" s))
                          (set! s (substring s 2))
                          16]
                         [(string-prefix? "0" s)
                          (set! s (substring s 1))
                          8]
                         [(zero? r)
                          10]
                         [else r])])
                (cond
                  [(regexp-match (build-integer-regexp r) s)
                   => (lambda (match)
                        (let sum ([factor 1]
                                  [total 0]
                                  [digits (map char->digit (reverse (string->list (car match))))])
                          (if (null? digits)
                              total
                              (sum (* factor r)
                                   (+ total (* (car digits) factor))
                                   (cdr digits)))))]
                  [else +nan.0]))))))))

(define (char->digit ch)
  (cond
    [(memv ch (string->list "0123456789"))
     (- (char->integer ch) (char->integer #\0))]
    [(memv ch (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
     (- (char->integer ch) (char->integer #\A))]
    [(memv ch (string->list "abcdefghijklmnopqrstuvwxyz"))
     (- (char->integer ch) (char->integer #\a))]
    [else
     (error 'char->digit "bad digit: ~a" ch)]))

(define (build-integer-regexp base)
  (regexp
   (cond
     [(<= base 10)
      (format "^[0-~a]+" (sub1 base))]
     [(= base 11)
      "^[0-9Aa]+"]
     [else
      (let ([last-char-index (- base 11)])
        (format "^[0-9A-~aa-~a]+"
                (string-ref "ABCDEFGHIJKLMNOPQRSTUVWXYZ" last-char-index)
                (string-ref "abcdefghijklmnopqrstuvwxyz" last-char-index)))])))

;; 15.1.2.3
(define js:parseFloat
  (build-function 1
    (lambda (args)
      (let ([s (string-trim (value->string (if (> (evector-length args) 0)
                                               (evector-ref args 0)
                                               (void)))
                            char-whitespace?)])
        (cond
          [(regexp-match rx:float s)
           => (lambda (match)
                ;; TODO: calculate the MV according to 9.3.1
                (string->number (car match)))]
          [else +nan.0])))))

(define js:isNaN
  (build-function 1
    (lambda (args)
      (make-boolean (NaN? (value->number (if (> (evector-length args) 0)
                                             (evector-ref args 0)
                                             (void))))))))

(define js:isFinite
  (build-function 1
    (lambda (args)
      (let ([x (value->number (if (> (evector-length args) 0)
                                  (evector-ref args 0)
                                  (void)))])
        (cond
          [(NaN? x) 'false]
          [(infinite? x) 'false]
          [else 'true])))))

(define js:eval
  (build-function 1
    (lambda (args)
      (if (zero? (evector-length args))
          (void)
          (eval-javascript-string (value->string (evector-ref args 0))
                                  (current-namespace))))))

(define (tmp:stub arity name)
  (build-function arity
    (lambda (args)
      (error name "not yet implemented"))))

(define js:decodeURI (tmp:stub 1 'decodeURI))
(define js:decodeURIComponent (tmp:stub 1 'decodeURIComponent))
(define js:encodeURI (tmp:stub 1 'encodeURI))
(define js:encodeURIComponent (tmp:stub 1 'encodeURIComponent))

;; 15.2.2.1
(define (new-Object arg-vec)
  (if (or (zero? (evector-length arg-vec))
          (null? (evector-ref arg-vec 0))
          (void? (evector-ref arg-vec 0)))
      (make-object #f #f proto:Object "Object" (object-table))
      (value->object (evector-ref arg-vec 0))))

;; 15.3.2.1
(define (new-Function arg-vec)
  (let ([args (evector->list arg-vec)])
    (cond
      [(null? args) (build-function 0 void)]
      [(null? (cdr args))
       (eval-function-string (format "function(){~a}" (value->string (car args)))
                             (current-namespace))]
      [else
       (eval-function-string (format "function(~a){~a}"
                                     (string-join (map value->string (drop-right args 1)) "," 'infix)
                                     (value->string (last args)))
                             (current-namespace))])))

;; 15.4.2.1
(define (new-Array arg-vec)
  (let ([len (evector-length arg-vec)])
    (if (= len 1)
        (new-Array1 (evector-ref arg-vec 0))
        (build-array arg-vec))))

;; 15.4.2.2
(define (new-Array1 len)
  (if (numeric? len)
      (let* ([val (numeric->number len)]
             [uint32 (value->uint32 val)])
        (if (= val uint32)
            (let ([a (build-array (evector))])
              (set-array-length! a uint32)
              a)
            (build-array (evector len))))
      (build-array (evector len))))

;; 15.5.2.1
(define (new-String arg-vec)
  (let* ([value (if (zero? (evector-length arg-vec))
                    ""
                    (value->string (evector-ref arg-vec 0)))]
         [table (object-table)])
    (hash-set! table '<<value>> value)
    (make-object #f #f proto:String "String" table)))

;; 15.6.2.1
(define (new-Boolean arg-vec)
  (let* ([value (if (zero? (evector-length arg-vec))
                    'false
                    (value->boolean (evector-ref arg-vec 0)))]
         [table (object-table)])
    (hash-set! table '<<value>> value)
    (make-object #f #f proto:Boolean "Boolean" table)))

;; 15.7.2.1
(define (new-Number arg-vec)
  (let* ([value (if (zero? (evector-length arg-vec))
                    0
                    (value->number (evector-ref arg-vec 0)))]
         [table (object-table)])
    (hash-set! table '<<value>> value)
    (make-object #f #f proto:Number "Number" table)))

(define (reset-object! object)
  (set-object-properties! object (object-table))
  (set-ref! eval-ref js:eval))

(define (reset-global-object! global)
  (reset-object! global)
  (reset-object! proto:global) ;; TODO: get this from (object-proto global) instead?
  (reset-object! proto:proto)
  
  (object-put! proto:global "toString" (build-function 0
                                         (lambda (arg-vec)
                                           (object-descriptor (current-this)))))
  (object-put! proto:global "hasOwnProperty" (build-function 1
                                               (lambda (arg-vec)
                                                 (make-boolean
                                                  (has-property?/immediate (current-this)
                                                                           (get-arg arg-vec 0)))))))

(define (reset-primitive-constructors! global)
  (for-each (lambda (ctor proto name call construct)
              (reset-object! proto)
              (reset-object! ctor)
              (set-object-call! ctor call)
              (set-object-construct! ctor construct)
              ;; 15.2.3.1, 15.3.3.1, 15.4.3.1, 15.5.3.1, 15.6.3.1, 15.7.3.1
              (object-put! ctor "prototype" proto (bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
              ;; 15, 15.2.3, 15.3.3, 15.4.3, 15.5.3, 15.6.3, 15.7.3
              (object-put! ctor "length" 1 (bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))                
              ;; 15?
              (object-put! global name ctor (bit-field DONT-ENUM? DONT-DELETE?))
              ;; 15.2.4.1, 15.3.4.1, 15.4.4.1, 15.5.4.1, 15.6.4.1, 15.7.4.1
              (object-put! proto "constructor" ctor))
            (list Object Function Array String Boolean Number)
            (list proto:Object proto:Function proto:Array proto:String proto:Boolean proto:Number)
            (list "Object" "Function" "Array" "String" "Boolean" "Number")
            (list
             ;; 15.2.1.1
             (lambda (arg-vec)
               (if (or (zero? (evector-length arg-vec))
                       (null? (evector-ref arg-vec 0))
                       (void? (evector-ref arg-vec 0)))
                   (new-Object arg-vec)
                   (value->object (evector-ref arg-vec 0))))
             ;; 15.3.1
             new-Function
             ;; 15.4.1
             new-Array
             ;; 15.5.1
             (compose value->string get-arg0)
             ;; 15.6.1
             (compose value->boolean get-arg0)
             ;; 15.7.1
             (compose value->number get-arg0))
            (list new-Object new-Function new-Array new-String new-Boolean new-Number))
  (reset-object! Math)
  (object-put! global "Math" Math (bit-field DONT-ENUM? DONT-DELETE?)))

(define Object-methods
  `(;; 15.2.4.2
    (toString           ,(build-function 0
                           (lambda (arg-vec)
                             (object-descriptor (current-this)))))
    ;; 15.2.4.3
    (toLocaleString     ,(build-function 0
                           (lambda (arg-vec)
                             (let ([toString (object-get (current-this) "toString")])
                               (if (not toString)
                                   (raise-runtime-type-error here "function" "undefined")
                                   (call toString arg-vec (lambda (s1 s2)
                                                            (raise-runtime-type-error here s1 s2))))))))
    ;; 14.2.4.4
    (valueOf            ,(build-function 0
                           (lambda (arg-vec)
                             (current-this))))
    ;; 15.2.4.5
    (hasOwnProperty     ,(build-function 0
                           (lambda (arg-vec)
                             (make-boolean
                              (has-property?/immediate (current-this)
                                                       (get-arg arg-vec 0))))))
    ;; 15.2.4.6
    (isPrototypeOf      ,(tmp:stub 1 "isPrototypeOf"))
    ;; 15.2.4.7
    (propertyIsEnumerable ,(tmp:stub 1 "propertyIsEnumerable"))
    ))

(define Function-methods
  `(;; 15.3.4.2
    (toString           ,(build-function 0
                           (lambda (arg-vec)
                             (unless (descendant-of? (current-this) proto:Function)
                               (raise-runtime-type-error here "function" "object"))
                             ;; TODO: show function source
                             "[object Function]")))
    ;; 15.3.4.3
    (apply              ,(tmp:stub 2 "apply"))
    ;; 15.3.4.4
    (call               ,(tmp:stub 1 "call"))
    ))

(define Array-methods
  `(;; 15.4.4.2
    (toString           ,(build-function 0
                           (lambda (arg-vec)
                             (let ([this (current-this)])
                               ;; TODO: should actually extract elements one by one, generically
                               (string-join (map (lambda (elt)
                                                   (if elt (value->string elt) ""))
                                                 (evector->list (array-vector this)))
                                            ","
                                            'infix)))))
    ;; 15.4.4.3
    (toLocaleString     ,(build-function 0
                           (lambda (arg-vec)
                             (let ([this (current-this)])
                               (unless (descendant-of? this proto:Array)
                                 (raise-runtime-type-error here "array" "object"))
                               ;; TODO: should actually extract elements one by one
                               (string-join (map (lambda (elt)
                                                   (if elt
                                                       (invoke elt "toLocaleString" (evector) (lambda (s1 s2)
                                                                                                (raise-runtime-type-error here s1 s2)))
                                                       ""))
                                                 (evector->list (array-vector this)))
                                            ;; TODO: use locale info to choose separator
                                            ","
                                            'infix)))))
    ;; 15.4.4.4
    (concat             ,(tmp:stub 1 "concat"))
    ;; 15.4.4.5
    (join               ,(tmp:stub 1 "join"))
    ;; 15.4.4.6
    (pop                ,(tmp:stub 0 "pop"))
    ;; 15.4.4.7
    (push               ,(tmp:stub 1 "push"))
    ;; 15.4.4.8
    (reverse            ,(tmp:stub 0 "reverse"))
    ;; 15.4.4.9
    (shift              ,(tmp:stub 0 "shift"))
    ;; 15.4.4.10
    (slice              ,(tmp:stub 2 "slice"))
    ;; 15.4.4.11
    (sort               ,(tmp:stub 1 "sort"))
    ;; 15.4.4.12
    (splice             ,(tmp:stub 2 "splice"))
    ;; 15.4.4.13
    (unshift            ,(tmp:stub 1 "unshift"))
    ))

(define String-statics
  `(;; 15.5.3.2
    (fromCharCode       ,(build-function 1
                           (lambda (arg-vec)
                             (list->string
                              (map (compose integer->char value->uint16)
                                   (evector->list arg-vec))))))
    ))

(define String-methods
  `(;; 15.5.4.2
    (toString           ,(build-function 0
                           (lambda (arg-vec)
                             (current-this))))
    ;; 15.5.4.3
    (valueOf            ,(tmp:stub 0 "valueOf"))
    ;; 15.5.4.4
    (charAt             ,(tmp:stub 1 "charAt"))
    ;; 15.5.4.5
    (charCodeAt         ,(tmp:stub 1 "charCodeAt"))
    ;; 15.5.4.6
    (concat             ,(tmp:stub 1 "concat"))
    ;; 15.5.4.7
    (indexOf            ,(tmp:stub 1 "indexOf"))
    ;; 15.5.4.8
    (lastIndexOf        ,(tmp:stub 1 "lastIndexOf"))
    ;; 15.5.4.9
    (localeCompare      ,(tmp:stub 1 "localeCompare"))
    ;; 15.5.4.10
    (match              ,(tmp:stub 1 "match"))
    ;; 15.5.4.11
    (replace            ,(tmp:stub 2 "replace"))
    ;; 15.5.4.12
    (search             ,(tmp:stub 1 "search"))
    ;; 15.5.4.13
    (slice              ,(tmp:stub 2 "slice"))
    ;; 15.5.4.14
    (split              ,(tmp:stub 2 "split"))
    ;; 15.5.4.15
    (substring          ,(tmp:stub 2 "substring"))
    ;; 15.5.4.16
    (toLowerCase        ,(tmp:stub 0 "toLowerCase"))
    ;; 15.5.4.17
    (toLocaleLowerCase  ,(tmp:stub 0 "toLocaleLowerCase"))
    ;; 15.5.4.18
    (toUpperCase        ,(tmp:stub 0 "toUpperCase"))
    ;; 15.5.4.19
    (toLocaleUpperCase  ,(tmp:stub 0 "toLocaleUpperCase"))
    ))

(define Boolean-methods
  `(;; 15.6.4.2
    (toString           ,(tmp:stub 0 "toString"))
    ;; 15.6.4.3
    (valueOf            ,(tmp:stub 0 "valueOf"))
    ))

(define Number-statics
  `(;; 15.7.3.2
    ;; TODO: fix this
    (MAX_VALUE          ,(void)               ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?))
    ;; 15.7.3.3
    ;; TODO: fix this
    (MIN_VALUE          ,(void)               ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?))
    ;; 15.7.3.4
    (NaN                +nan.0                ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?))
    ;; 15.7.3.5
    (NEGATIVE_INFINITY  -inf.0                ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?))
    ;; 15.7.3.6
    (POSITIVE_INFINITY  +inf.0                ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?))
    ))

(define Number-methods
  `(;; 15.7.4.2
    (toString           ,(tmp:stub 0 "toString"))
    ;; 15.7.4.3
    (toLocaleString     ,(tmp:stub 0 "toLocaleString"))
    ;; 15.7.4.4
    (valueOf            ,(tmp:stub 0 "valueOf"))
    ;; 15.7.4.5
    (toFixed            ,(tmp:stub 1 "toFixed"))
    ;; 15.7.4.6
    (toExponential      ,(tmp:stub 1 "toExponential"))
    ;; 15.7.4.7
    (toPrecision        ,(tmp:stub 1 "toPrecision"))
    ))

;; 15.8.1
(define Math-static-properties
  `(;; 15.8.1.1
    (E                  ,(exp 1)              ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.2
    (LN10               ,(log 10)             ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.3
    (LN2                ,(log 2)              ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.4
    (LOG2E              ,(/ 1 (log 2))        ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.5
    (LOG10E             ,(/ 1 (log 10))       ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.6
    (PI                 ,pi                   ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.7
    (SQRT1_2            ,(sqrt 1/2)           ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ;; 15.8.1.8
    (SQRT_2             ,(sqrt 2)             ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?))
    ))

;; 15.8.2
(define Math-static-methods
  `(;; 15.8.2.1
    (abs ,(tmp:stub 1 "abs"))
    ;; 15.8.2.2
    (acos ,(tmp:stub 1 "acos"))
    ;; 15.8.2.3
    (asin ,(tmp:stub 1 "asin"))
    ;; 15.8.2.4
    (atan ,(tmp:stub 1 "atan"))
    ;; 15.8.2.5
    (atan2 ,(tmp:stub 2 "atan2"))
    ;; 15.8.2.6
    (ceil ,(tmp:stub 1 "ceil"))
    ;; 15.8.2.7
    (cos ,(tmp:stub 1 "cos"))
    ;; 15.8.2.8
    (exp ,(tmp:stub 1 "exp"))
    ;; 15.8.2.9
    (floor ,(tmp:stub 1 "floor"))
    ;; 15.8.2.10
    (log ,(tmp:stub 1 "log"))
    ;; 15.8.2.11
    (max ,(tmp:stub 2 "max"))
    ;; 15.8.2.12
    (min ,(tmp:stub 2 "min"))
    ;; 15.8.2.13
    (pow ,(tmp:stub 2 "pow"))
    ;; 15.8.2.14
    (random ,(tmp:stub 0 "random"))
    ;; 15.8.2.15
    (round ,(tmp:stub 1 "round"))
    ;; 15.8.2.16
    (sin ,(tmp:stub 1 "sin"))
    ;; 15.8.2.17
    (sqrt ,(tmp:stub 1 "sqrt"))
    ;; 15.8.2.18
    (tan ,(tmp:stub 1 "tan"))
    ))

(define global-properties
  `(;; 15.1.1.1
    (NaN                +nan.0                ,(bit-field DONT-ENUM? DONT-DELETE?))
    ;; 15.1.1.2
    (Infinity           +inf.0                ,(bit-field DONT-ENUM? DONT-DELETE?))
    ;; 15.1.1.3
    (undefined          ,(void)               ,(bit-field DONT-ENUM? DONT-DELETE?))
    ))

(define eval-ref
  (let ([state js:eval])
    (make-ref (lambda () state)
              (lambda (val)
                (set! state val)
                (original-eval? (eq? val js:eval))
                val)
              (lambda () 'true))))

(define global-methods
  `(;; 15.1.2.1
    (eval               ,eval-ref             ,(bit-field DONT-DELETE?))
    ;; 15.1.2.2
    (parseInt           ,js:parseInt)
    ;; 15.1.2.3
    (parseFloat         ,js:parseFloat)
    ;; 15.1.2.4
    (isNaN              ,js:isNaN)
    ;; 15.1.2.5
    (isFinite           ,js:isFinite)
    ;; 15.1.3.1
    (decodeURI          ,js:decodeURI)
    ;; 15.1.3.2
    (decodeURIComponent ,js:decodeURIComponent)
    ;; 15.1.3.3
    (encodeURI          ,js:encodeURI)
    ;; 15.1.3.4
    (encodeURIComponent ,js:encodeURIComponent)
    ))

(define global-custom-properties
  `((it                 ,(void)               ,(bit-field DONT-ENUM? DONT-DELETE?))
    ))

(define global-custom-methods
  `(;; 15
    (print              ,js:print)
    ))

(define (install-properties! object properties)
  (for-each (lambda (property)
              (match property
                [(list name value)
                 (object-put! object (symbol->string name) value (bit-field DONT-ENUM?))]
                [(list name value attributes)
                 (object-put! object (symbol->string name) value attributes)]))
            properties))

(define (install-standard-library! global)
  (reset-global-object! global)
  (reset-primitive-constructors! global)

  (install-properties! global         global-properties)
  (install-properties! global         global-methods)
  (install-properties! global         global-custom-properties)
  (install-properties! global         global-custom-methods)

  (install-properties! proto:Object   Object-methods)
  (install-properties! proto:Function Function-methods)
  (install-properties! proto:Array    Array-methods)
  (install-properties! String         String-statics)
  (install-properties! proto:String   String-methods)
  (install-properties! proto:Boolean  Boolean-methods)
  (install-properties! Number         Number-statics)
  (install-properties! proto:Number   Number-methods)
  (install-properties! Math           Math-static-properties)
  (install-properties! Math           Math-static-methods)

  (current-this global)
  (original-eval? #t)
  global)