(module standard-library mzscheme
  (require (planet "evector.scm" ("soegaard" "evector.plt" 1 0))
           (only (lib "mred.ss" "mred") message-box)
           (lib "string.ss" "srfi" "13")
           "../syntax/regexps.ss"
           "exceptions.ss"
           "value.ss")

  (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:alert
    (build-function 1
     (lambda (args)
       (let ([args (evector->list args)])
         (when (null? args)
           (raise-runtime-exception here "not enough arguments"))
         (let* ([msg (value->string (car args))]
                [msg-padded (if (< (string-length msg) 20)
                                (string-pad-right msg 20 #\space)
                                msg)])
           (message-box "JavaScript" msg-padded #f '(ok)))
         (void)))))

  (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)
        (let ([x (if (> (evector-length args) 0)
                     (evector-ref args 0)
                     (void))])
          (if (string? x)
              ;; TODO: implement me!
              (raise-runtime-exception here "not yet implemented")
              x)))))

  (define (install-prototype-methods! proto methods)
    (for-each (lambda (pair)
                (object-put! proto
                             (symbol->string (car pair))
                             (cdr pair)
                             (bit-field DONT-ENUM?)))
              methods))

  (define (install-standard-library! global)
    (define Array-methods
      `((toString . ,(build-function 0
                       (lambda (arg-vec)
                         (let ([this (current-this)])
                           (string-join (map (lambda (elt)
                                               (if elt (value->string elt) ""))
                                             (evector->list (array-vector this)))
                                        ","
                                        'infix)))))))

    (define Object-methods
      `((toString . ,(build-function 0
                       (lambda (arg-vec)
                         (let ([this (current-this)])
                           (format "[object ~a]" (object-class this))))))
        (valueOf . ,(build-function 0
                      (lambda (arg-vec)
                        (current-this))))))

    (define Function-methods
      `((toString . ,(build-function 0
                       (lambda (arg-vec)
                         "[object Function]")))))

    (current-this global)

    (object-put! global "NaN"        +nan.0        (bit-field DONT-ENUM? DONT-DELETE?))
    (object-put! global "Infinity"   +inf.0        (bit-field DONT-ENUM? DONT-DELETE?))
    (object-put! global "undefined"  (void)        (bit-field DONT-ENUM? DONT-DELETE?))
    (object-put! global "parseInt"   js:parseInt   (bit-field DONT-ENUM?))
    (object-put! global "parseFloat" js:parseFloat (bit-field DONT-ENUM?))
    (object-put! global "isNaN"      js:isNaN      (bit-field DONT-ENUM?))
    (object-put! global "isFinite"   js:isFinite   (bit-field DONT-ENUM?))
    (object-put! global "eval"       js:eval       (bit-field DONT-ENUM?))
    (object-put! global "it"         (void)        (bit-field DONT-ENUM? DONT-DELETE?))

    (install-prototype-methods! proto:Object Object-methods)
    (install-prototype-methods! proto:Function Function-methods)
    (install-prototype-methods! proto:Array Array-methods)

    ;; 15
    (object-put! global "print" js:print (bit-field DONT-ENUM?))
    (object-put! global "alert" js:alert (bit-field DONT-ENUM?)))

  (provide install-standard-library!))