core.ralph

(define-module ralph/core
  export: (<object> <string> <number> <array>
           <boolean> <function> <error>
           %annotate-function true? not size %inherit
           %make-class %keywords <keyword> keyword %keys
           %make-exit-function <non-local-exit>
           %concat cons as-string as-number as-array
           as-json parse-json
           parse-number parse-integer char-code code-char
           empty? rest last (setter last) first (setter first)
           second (setter second) third (setter third)
           make-array push push-last pop
           pop-last but-last every? reduce1
           reduce reverse! reverse choose
           find-key position last-position member? count
           sort! sort apply curry
           rcurry always repeatedly identity
           complement compose + - * / type
           instance? has? %make-method %make-generic
           %next-method concatenate
           compare binary== == binary= = binary< <
           binary<= <= binary> > binary>= >=
           as-object as-uppercase as-lowercase
           join trim replace make-object make-plain-object
           <symbol> symbol symbol-name
           destructure-symbol %%symbol
           element (setter element)
           replace-subsequence replace-subsequence!
           remove remove!
           interpose any? map do copy-sequence slice
           object-properties object-values
           make initialize
           get (setter get) remove-property!
           <hash-symbol> inc dec split split-with
           as-hex-string description min max abs
           round floor ceil sin cos atan2 expt sqrt
           mod $pi as-radiant even? odd?
           signal starts-with? ends-with?
           as-property-list as-association-list
           extend! update-with group-by
           chain-object unchain-object
           as-set set-union! set-add!
           set-subtract! set-remove!
           conjoin disjoin ignore
           reset-symbol-counter! generate-symbol
           set-timeout clear-timeout
           set-interval clear-interval
           partition
           ;; core special forms
           quote bind method set! define if
           begin while handler-case
           ;; internal special forms
           %quote %bind %method %set %define %if
           %begin %while %try %var
           %native-call %infix %native
           %object %array %get-property
           ;; core macros
           when unless parallel-set! cond
           and or if-bind until dotimes for
           for-each select destructuring-bind
           bind-properties bind-methods
           inc! dec! .
           define-function define-method
           define-class define-generic
           define-module define-macro
           define-symbol-macro
           syntax-quote unquote unquote-splicing
           call-next-method next-method
           once-only repeat-string substring
           expression?)
  inline: (not size cons
           as-string as-number as-array as-json
           parse-number char-code empty?
           rest last (setter last) but-last
           slice %concat reverse! reverse
           first second third
           (setter first) (setter second) (setter third)
           replace push push-last pop pop-last
           as-hex-string starts-with?
           as-uppercase as-lowercase trim
           inc dec mod as-radiant even? odd?
           has? signal binary==))

(define <object> (%native "Object"))
(define <string> (%native "String"))
(define <number> (%native "Number"))
(define <array> (%native "Array"))
(define <boolean> (%native "Boolean"))
(define <function> (%native "Function"))
(define <error> (%native "Error"))

(set! (%get-property <error> "%properties")
      (%object "message" #f))

(define %annotate-function
  (method (function name setter?)
    (set! (%get-property function "%name") name)
    (set! (%get-property function "%setter?") setter?)
    function))

(define-function true? (value)
  (%infix "&&"
          (%infix "!=" value (%native "null"))
          (%infix "!==" value #f)))

(%native "$T = " true?)

(define-function not (value)
  (%native-call "!" (true? value)))

(define-function size (object)
  (%infix "||"
          (%get-property (%infix "||" object #f)
                         "length")
          0))

(%native "$SL = [].slice")

(define-function inc ((number <number>))
  (%infix "+" number 1))

(define-function dec ((number <number>))
  (%infix "-" number 1))

(define-function binary== (object1 object2)
  (%infix "===" object1 object2))

(define-function %inherit (class superclass)
  (set! (%get-property class "%superclass")
        superclass)
  (set! (%get-property class "prototype" "__proto__")
        (%get-property superclass "prototype"))
  (bind ((super-properties (%get-property superclass "%properties")))
    (when (%infix "instanceof" super-properties <object>)
      (set! (%get-property class "%properties" "__proto__")
            super-properties)))
  class)

(define-function %make-class (superclass properties constructor)
  (unless constructor
    (set! constructor (method ())))
  (set! (%get-property constructor "%properties")
        properties)
  (set! (%get-property constructor "%class?") #t)
  (when superclass
    (%inherit constructor superclass))
  constructor)

(define %keywords (%object))

(define-class <keyword> (<object>)
  name)

(define-function keyword (name)
  (bind ((name* (. name ("toLowerCase"))))
    (or (%get-property %keywords name*)
        (bind ((keyword (%native-call "new" <keyword>)))
          (set! (%get-property keyword "name") name)
          (set! (%get-property %keywords name) keyword)
          keyword))))

(%native "$K = " keyword)

(define *exit-function-counter* 0)

(define-class <non-local-exit> (<object>))

(define-function %make-exit-function ()
  (bind ((identifier (inc! *exit-function-counter*))
         (exit-function (method (return-value)
                          (bind ((condition (%native-call "new" <non-local-exit>)))
                            (set! (%get-property condition "identifier")
                                  identifier)
                            (set! (%get-property condition "return-value")
                                  return-value)
                            (signal condition)))))
    (set! (%get-property exit-function "identifier")
          identifier)
    exit-function))


(define-function %concat ((array1 <array>) (array2 <array>))
  (. array1 ("concat" array2)))

(define-function cons (value rest)
  (%concat [value] rest))

(define as-string (%native "String"))

(define as-number (%native "Number"))

(define-function as-array (arguments skip)
  (%native-call "$SL.call" arguments (%infix "||" skip 0)))

(define-function as-json (value #key (replacer (%native "null"))
                                     indent)
  (%native-call "JSON.stringify" value replacer indent))

(define parse-json (%native "JSON.parse"))

(define parse-number (%native "parseFloat"))

(define-function char-code (char)
  (. char ("charCodeAt" 0)))

(define code-char (%native "String.fromCharCode"))


;; TODO: !array.length
(define-function empty? (sequence)
  (binary== (size sequence) 0))

(define-function rest (sequence)
  (. sequence ("slice" 1)))

(define-function last ((array <array>))
  (%get-property array (dec (size array) 1)))

(define-function (setter last) ((array <array>) value)
  (set! (%get-property array (dec (size array) 1))
        value))

(define-function first (sequence)
  (%get-property sequence 0))

(define-function (setter first) ((array <array>) value)
  (set! (%get-property array 0) value))

(define-function second (sequence)
  (%get-property sequence 1))

(define-function (setter second) ((array <array>) value)
  (set! (%get-property array 1) value))

(define-function third (sequence)
  (%get-property sequence 2))

(define-function (setter third) ((array <array>) value)
  (set! (%get-property array 2) value))

;; TODO: inline
(define-function make-array (#rest elements)
  elements)

(define-function push ((array <array>) value)
  (. array ("unshift" value))
  value)

(define-function push-last ((array <array>) value)
  (. array ("push" value))
  value)

(define-function pop ((array <array>))
  (. array ("shift")))

(define-function pop-last ((array <array>))
  (. array ("pop")))

(define-function but-last ((array <array>) n)
  (. array ("slice" 0 (%infix "*" (%infix "||" n 1) -1))))

(define-function slice ((array <array>) start end)
  (. array ("slice" start end)))

(define-function reduce1 ((function <function>) (values <array>) #key from-end?)
  (if (empty? values)
      (function)
      (apply reduce function
             (%concat
              (if from-end?
                  [(last values) (but-last values)]
                  [(first values) (rest values)])
              [from-end?: from-end?]))))

(define-function reduce
    ((function <function>) initial-value (values <array>) #key from-end?)
  (bind ((result initial-value))
    (if from-end?
        (bind ((values (reverse values)))
          (dotimes (i (size values))
            (set! result (function (%get-property values i)
                                   result))))
        (dotimes (i (size values))
          (set! result (function result
                                 (%get-property values i)))))
    result))

(define-function reverse! ((array <array>))
  (. array ("reverse")))

(define-function reverse ((array <array>))
  (reverse! (slice array)))

(define-function sort! ((array <array>) #key (test <) (key identity))
  (. array ("sort" (method (a b)
                     (if (test (key a)
                               (key b))
                         -1 1)))))

(define-function sort ((array <array>) #key (test <) (key identity))
  (sort! (slice array)
         test: test key: key))

;; TODO: choose-by

(define-function apply ((function <function>))
  (bind ((actual (%native-call "$SL.call" %all-arguments 1 -1))
         (last (%get-property %all-arguments
                              (%infix "-" (size %all-arguments) 1)))
         (arguments (if (binary== last function)
                        actual
                        (%concat actual last))))
    ((%get-property function "apply")
     (%native "null") arguments)))

(define-function curry ((function <function>) #rest curried-args)
  (method (#rest args)
    (apply function (%concat curried-args args))))

(define-function rcurry ((function <function>) #rest curried-args)
  (method (#rest args)
    (apply function (%concat args curried-args))))

(define-function always (value)
  (method ()
    value))

(define-function repeatedly ((function <function>) (count <integer>))
  (bind ((result []))
    (dotimes (i count result)
      (push-last result (function)))))

(define-function identity (value)
  value)

(define-function complement ((function <function>))
  (method (#rest arguments)
    (not (apply function arguments))))

(define-function compose (#rest functions)
  (if (empty? functions)
      identity
      (method (#rest arguments)
        (reduce (method (function value)
                  (function value))
                (apply (last functions)
                       arguments)
                (but-last functions)
                from-end?: #t))))

(define-function binary+ (number1 number2)
  (%infix "+" number1 number2))

(define-function binary- (number1 number2)
  (%infix "-" number1 number2))

(define-function binary* (number1 number2)
  (%infix "*" number1 number2))

(define-function binary/ (number1 number2)
  (%infix "/" number1 number2))



(define-function type (object)
  (if object
      (%get-property object "constructor")
      <boolean>))

(define-function instance? (object type)
  (if object
      (%infix "||"
              ;; object
              (%infix "instanceof" object type)
              ;; primitive
              (binary== (%get-property object "constructor")
                        type))
      (binary== type <boolean>)))

(%native "$HP = Object.hasOwnProperty")

(define-function has? (object property)
  (%native "$HP.call(" object "," property ")"))

(define-function %make-method (name function setter? type existing)
  ;; definition
  (set! (%get-property function "%name") name)
  (set! (%get-property function "%setter?") setter?)
  (set! (%get-property function "%type") type)
  (set! (%get-property type "prototype" name) function)
  ;; implicit definition of generic function?
  (if (and existing
           (%get-property existing "%generic?"))
      existing
      (%make-generic name)))

(define-function %make-generic (name)
  (bind ((dispatcher
          (method (object)
            (bind ((function (%get-property
                              (%native "(" object "== null ?"
                                       " false : " object ")")
                              name)))
              (%infix "&&"
                      function
                      ((%get-property function "apply")
                       object %all-arguments))))))
    (set! (%get-property dispatcher "%generic?") #t)
    (set! (%get-property dispatcher "%name") name)
    dispatcher))

(define-function %next-method (function)
  (bind ((name (%get-property function "%name"))
         (proto (%get-property function "%type"
                               "prototype" "__proto__")))
    (%get-property proto name)))


(define-function concatenate (#rest values)
  (if (empty? values)
      []
      (reduce1 %concat values)))

(define-function compare ((function <function>) object objects)
  (bind ((failed? #f))
    (until (or failed? (empty? objects))
      (bind ((other (first objects)))
        (set! failed? (not (function object other)))
        (set! objects (rest objects))
        (set! object other)))
    (not failed?)))


(define-function == (object #rest objects)
  (compare binary== object objects))

(define-generic binary= (object1 object2))
(define-generic binary< (object1 object2))

(define-method binary= (object1 object2)
  (and (binary== (type object1)
                 (type object2))
       (binary== object1
                 object2)))

(define-method binary= ((array1 <array>) (array2 <array>))
  (and (binary== (size array1)
                 (size array2))
       ;; NB: twisted logic
       (not (for-each ((item1 array1)
                       (item2 array2))
                      ((not (binary= item1 item2)) #t)))))

;; fix binary= for undefined and null
;; (dispatcher won't find above method)

(define binary=-dispatcher binary=)
(define-function binary= (object1 object2)
  (or (and (not object1)
           (not object2))
      (binary=-dispatcher object1 object2)))

(define-function = (object #rest objects)
  (compare binary= object objects))

;; TODO: (define-method binary= ((array1 <array>) (array2 <array>)))

(define-method binary< (object1 object2)
  (and (binary== (type object1)
                 (type object2))
       (%infix "<" object1 object2)))

(define-function < (object #rest objects)
  (compare binary< object objects))

(define-function binary<= (object1 object2)
  (and object1
       object2
       (or (binary< object1 object2)
           (binary= object1 object2))))

(define-function <= (object #rest objects)
  (compare binary<= object objects))

(define-function binary> (object1 object2)
  (and object1
       object2
       (not (binary< object1 object2))
       (not (binary= object1 object2))))

(define-function > (object #rest objects)
  (compare binary> object objects))

(define-function binary>= (object1 object2)
  (or (not (binary< object1 object2))
      (binary= object1 object2)))

(define-function >= (object #rest objects)
  (compare binary>= object objects))

(define-function as-object (property-list)
  (bind ((list (slice property-list))
         (result (%object)))
    (while (> (size list) 0)
      (bind ((key (pop list))
             (value (pop list)))
        (set! key (if (instance? key <keyword>)
                      (%get-property key "name")
                      (as-string key)))
        (set! (%get-property result key)
              value)))
    result))

;; <array> <object> or <string> <string>
(define-function position ((array <array>) element #key (start 0))
  (bind ((position (. array ("indexOf" element start))))
    (when (> position -1)
      position)))

(define-function last-position ((array <array>) element)
  (bind ((position (. array ("lastIndexOf" element))))
    (when (> position -1)
      position)))

(define-function count (item (array <array>))
  (for ((result -1 (inc result))
        (pos 0 (position array item start: (inc pos))))
       ((not pos) result)))

(define-function as-uppercase ((string <string>))
  (. string ("toUpperCase")))

(define-function as-lowercase ((string <string>))
  (. string ("toLowerCase")))

;; TODO: generic interpose, interleave
(define-function join ((array <array>) (string <string>))
  (. array ("join" string)))

(define-function trim ((string <string>))
  (. string ("trim")))

(define-function replace ((string <string>) pattern replacement)
  (. string ("replace" pattern replacement)))


(define-function make-object (#rest key-values)
  (as-object key-values))


(define-class <symbol> (<object>)
  name
  module)

(define %symbols (%object))

(define-function symbol (name module)
  (%%symbol (as-lowercase name)
            (when module
              (as-lowercase module))))

(define-function symbol-name (symbol)
  (get symbol "name"))

(define-function destructure-symbol (symbol)
  [(get symbol "name")
   (get symbol "module")])

(define-function %%symbol (name module)
  (bind ((module* (or module "")))
    (or (get %symbols module* name)
        (set! (get %symbols module* name)
              (make <symbol>
                    name: name
                    module: module)))))

(%native "$S = " %%symbol)

(define *symbol-count* 0)

(define-function reset-symbol-counter! ()
  (set! *symbol-count* 0))

(define-function generate-symbol (env prefix)
  (bind ((name (concatenate
                (if prefix
                    (concatenate prefix "_")
                    "$")
                (as-string (inc! *symbol-count*))))
         (result (symbol name (when env
                                (get env "module" "name")))))
    (set! (get result "generated?") #t)
    result))

;; handles keyword arguments
(define-function %keys (key-values defaults)
  (for ((i 0 (inc i 2)))
       ((%infix ">=" i (size key-values)))
    (bind ((key (%get-property key-values i))
           (value (%get-property key-values (inc i 1))))
      (when (instance? key <keyword>)
        (set! (%get-property defaults (%get-property key "name"))
              value))))
  defaults)

;; TODO: improve
(define-function find-key ((array <array>) (predicate <function>)
                           #key (skip 0) failure from-end?)
  (bind ((keys (object-properties array))
         (satisfying-keys
          (choose (method (index)
                    (predicate (element array index)))
                  (if from-end?
                      (reverse keys)
                      keys))))
    (or (element satisfying-keys skip)
        failure)))

(define-function parse-integer (value #key (radix 10))
  (%native-call "parseInt" value radix))

(define-function element ((array <array>) index #key default)
  (or (%get-property array index)
      default))

(define-function (setter element) ((array <array>) key value)
  (set! (%get-property array key) value))

(define-function replace-subsequence ((target-array <array>) (insert-array <array>)
                                      #key (start 0) (end (size target-array)))
  (concatenate (slice target-array 0 start)
               insert-array
               (slice target-array end)))

(define-function replace-subsequence! ((target-array <array>) (insert-array <array>)
                                       #key (start 0) (end (size target-array)))
  ;; TODO: warn if string!
  (bind ((rest (%concat [start (- end start)]
                        insert-array)))
    ((%get-property [] "splice" "apply") target-array rest)
    target-array))


(define-function remove! ((array <array>) value #key (test ==))
  (if-bind (key (find-key array (curry test value)))
    (. array ("splice" key 1)))
  array)

(define-function remove ((array <array>) value #key (test ==))
  (remove! (slice array) value test: test))

(define-function interpose (separator (array <array))
  (reduce1 (method (a b)
             (concatenate [a separator] b))
           array))

(define-function any? ((function <function>) (values <array>))
  (bind ((value #f)
         (n (size values)))
    (for ((i 0 (inc i)))
         ((or value (>= i n)) value)
      (set! value
            (function (%get-property values i))))))

(define-function member? (value (array <array>) #key (test binary==))
  (any? (method (other-value)
          (test value other-value))
        array))

(define-function every? ((function <function>) (array <array>))
  (not (any? (complement function)
             array)))

(define-function map ((function <function>) #rest arrays)
  (bind ((result []))
    (if (empty? (rest arrays))
        (for-each ((item (first arrays)))
                  ()
          (push-last result (function item)))
        (until (any? empty? arrays)
          (push-last result
                     (apply function (map first arrays)))
          (set! arrays (map rest arrays))))
    result))

(define-function do ((function <function>) #rest arrays)
  (if (empty? (rest arrays))
      (for-each ((item (first arrays)))
                ()
        (function item))
      (until (any? empty? arrays)
        (apply function (map first arrays))
        (set! arrays (map rest arrays))))
  #f)

(define-function choose ((function <function>) (array <array>))
  (bind ((result []))
    (for-each ((element array))
              ()
      (when (function element)
        (push-last result element)))
    result))

(define-function copy-sequence ((array <array>) #key (start 0) end)
  (bind ((end (or end (%native "undefined"))))
    (slice array start end)))

(define-function make (type #rest arguments)
  (bind ((object (%native-call "new" type)))
    (apply initialize object arguments)
    object))

(define-function object-properties (object #key inherited?)
  (if (instance? object <array>)
      (bind ((result []))
        (dotimes (i (size object))
          (push-last result i))
        result)
      (if (or inherited?
          (%infix "!==" (%native-call "typeof" object)
                        "object"))
          (bind (i (result []))
            (%native "for (" i " in " object ") "
                     "(" inherited? "||"
                     "$HP.call(" object ", " i ")) &&"
                     result ".push(" i ")")
            result)
          (%native-call "Object.keys" object))))


(define-function object-values (object)
  (map (method (property)
         (get object property))
       (object-properties object)))

(define-generic initialize (object #rest))

(define-method initialize ((object <object>) #rest rest)
  (bind ((arguments (as-object rest)))
    (if-bind (properties (%get-property (type object)
                                        "%properties"))
      (do (method (property)
            (when (and (not (has? (%get-property <object> "prototype") property))
                       (%infix "==="
                               (%native-call "typeof"
                                             (%get-property object property))
                               "undefined"))
              (bind ((value (or (%get-property arguments property)
                                (bind ((value (%get-property properties property)))
                                  (when value
                                    (value))))))
                (set! (%get-property object property)
                      value))))
          (object-properties properties
                             inherited?: #t))))
  object)

(define-class <hash-symbol> (<object>)
    name)

(bind ((key (make <hash-symbol> name: "key")))
  (%native "$KEY = " key))

(bind ((rest (make <hash-symbol> name: "rest")))
  (%native "$REST = " rest))

(define-function get (object #rest properties)
  (bind ((result #f))
    (for-each ((property properties))
              ((not (has? object property))
               (set! result #f))
      (set! result (%get-property object property))
      (set! object result))
    result))

(define-function (setter get) (object #rest properties/value)
  (if (<= (size properties/value) 2)
      (set! (%get-property object (first properties/value))
            (second properties/value))
      (bind ((property (first properties/value))
             (object2 (if (has? object property)
                          (%get-property object property)
                          (set! (%get-property object property)
                                (make-object)))))
        (apply %this-method
               object2
               (rest properties/value)))))


(define-function remove-property! (object #rest properties)
  (bind ((result #t))
    (for-each ((property (but-last properties)))
              ((not (has? object property))
               (set! result #f))
      (set! result (%get-property object property))
      (set! object result))
    (when (instance? object <object>)
      (bind ((value (%get-property object (last properties))))
        (%native-call "delete" (%get-property object (last properties)))
        value))))


(define-function split (string separator)
  (. string (split separator)))

(define-function split-with (function array)
  (bind ((a [])
         (b []))
    (do (method (item)
          (push-last (if (function item) a b)
                     item))
        array)
    [a b]))


(define-function as-hex-string ((number <number>))
  (. number ("toString" 16)))

(define-generic description (object))

(define-method description ((number <number>))
  (%infix "+" "" number))

(define-method description ((string <string>))
  (bind ((escaped (. string ("replace" "\"" "\\\"" "g"))))
    (%infix "+" "\"" escaped "\"")))

(define-method description ((array <array>))
  (%infix "+" "(" (join (map description array) " ") ")"))

(define-method description ((value <boolean>))
  (if value "#t" "#f"))

(define-method description ((symbol <symbol>))
  (%infix "+" (if-bind (module (get symbol "module"))
                (concatenate module "::")
                "")
          (symbol-name symbol)))

(define-method description ((keyword <keyword>))
  (%infix "+" (symbol-name keyword) ":"))

(define-method description ((symbol <hash-symbol>))
  (%infix "+" "#" (symbol-name symbol)))

(define-method description ((function <function>))
  ;; TODO: include %name, and for class also %properties; requires
  ;;       passing ralph name to %annotate-function and %make-class
  (if (get function "%class?")
      "#{class}"
      "#{function}"))

(define min (%native "Math.min"))

(define max (%native "Math.max"))

(define abs (%native "Math.abs"))

(define round (%native "Math.round"))

(define floor (%native "Math.floor"))

(define ceil (%native "Math.ceil"))

(define sin (%native "Math.sin"))

(define cos (%native "Math.cos"))

(define atan2 (%native "Math.atan2"))

(define expt (%native "Math.pow"))

(define sqrt (%native "Math.sqrt"))

(define-function mod (number1 number2)
  (%infix "%" number1 number2))

(define $pi (%native "Math.PI"))

(define $radiant (%infix "/" $pi 180))

(define-function as-radiant (number)
  (* number $radiant))

(define-function signal ((error <error>))
  (%native-call "throw" error)
  #f)

(define-function extend! ((object1 <object>) (object2 <object>))
  (for-each ((key (object-properties object2)))
            ()
    (set! (get object1 key)
          (get object2 key)))
  object1)

(define-function as-property-list (object #key keywords?)
  (bind ((result []))
    (for-each ((key (object-properties object)))
              ()
      (push-last result
                 (if keywords?
                     (keyword (as-string key))
                     key))
      (push-last result (get object key)))
    result))

(define-function as-association-list (object #key keywords?)
  (bind ((result []))
    (for-each ((key (object-properties object)))
              ()
      (push-last result
                 [(if keywords?
                      (keyword (as-string key))
                      key)
                  (get object key)]))
    result))

(define-function starts-with? ((string <string>) (prefix <string>))
  (binary== (. string ("indexOf" prefix 0)) 0))

(define-function ends-with? (string suffix)
  (bind ((start-index (%infix "-" (%get-property string "length")
                                  (%get-property suffix "length")))
         (result-index (. string ("indexOf" suffix start-index))))
    (%binary== result-index start-index)))

(define-function even? (number)
  (binary== (%infix "%" number 2) 0))

(define-function odd? (number)
  (binary== (%infix "%" number 2) 1))

(define-function group-by (predicate items)
  (reduce (method (result item)
            (bind ((key (predicate item)))
              (if (has? result key)
                  (push-last (get result key) item)
                  (set! (get result key) [item])))
            result)
          (make-object)
          items))

(define-function wrap-object (object #rest rest)
  (bind ((result (%native-call "Object.create" object)))
    (extend! result (as-object rest))
    result))

(define-function unwrap-object (object)
  (%get-property object "__proto__"))

(define-function update-with (fn obj #rest objs)
  (do (method (obj2)
        (do (method (property)
              (bind ((value (get obj2 property)))
                (set! (get obj property)
                      (if (has? obj property)
                          (fn (get obj property)
                              value)
                          value))))
            (object-properties obj2)))
      objs))

(define-function as-set (values)
  (bind ((set []))
    (set-union! set values)))

(define-function set-add! (set object)
  (unless (member? object set)
    (push-last set object)))

(define set-remove! remove!)

(define-function set-union! (set1 set2)
  (do (curry set-add! set1) set2)
  set1)

(define-function set-subtract! (set1 set2)
  (do (curry set-remove! set1) set2)
  set1)


(define-function chain-object (object1 object2)
  (set! (%get-property object2 "__proto__")
        (%get-property object1 "__proto__"))
  (set! (%get-property object1 "__proto__")
        object2)
  object1)

(define-function unchain-object (object)
  (set! (%get-property object "__proto__")
        (when (%get-property object "__proto__")
          (%get-property object "__proto__" "__proto__")))
  object)

(define-function as-hex-string ((number <number>))
  (. number ("toString" 16)))

(define-function make-plain-object ()
  (%native "Object.create(null)"))

;; at end so (optimization) macro are applied in preceding code

(define-function - ((minuend <number>) #rest subtrahends)
  (if (empty? subtrahends)
      (%native-call "-" minuend)
      (reduce binary-
              minuend subtrahends)))

(define-function + (#rest numbers)
  (if (empty? numbers)
      0
      (reduce1 binary+
               numbers)))

(define-function * (#rest numbers)
  (if (empty? numbers)
      1
      (reduce1 binary*
               numbers)))

(define-function / ((numerator <number>) #rest denominators)
  (if (empty? denominators)
      (%divide 1 numerator)
      (reduce binary/
              numerator denominators)))


(define-function disjoin (predicate1 #rest predicates)
  (method (#rest arguments)
    (any? (method (predicate)
            (apply predicate
                   arguments))
          (cons predicate1
                predicates))))

(define-function conjoin (predicate1 #rest predicates)
  (method (#rest arguments)
    (bind ((value #f))
      (when (every? (method (predicate)
                      (set! value (apply predicate
                                         arguments)))
                    (cons predicate1
                          predicates))
        value))))

(define-function ignore ()
  #f)

(define set-timeout (%native "setTimeout"))

(define clear-timeout (%native "clearTimeout"))

(define set-interval (%native "setInterval"))

(define clear-interval (%native "clearInterval"))

(define-function partition (count elements #key (step count))
  (bind ((result [])
         (total (size elements))
         (last-index 0))
    (while (< last-index total)
      (bind ((new-index (+ last-index count)))
        (push-last result
                   (copy-sequence elements
                                  start: last-index
                                  end: new-index))
        (set! last-index new-index)))
    result))

(define-function repeat-string (string count)
  (bind ((result ""))
    (while (> count 0)
      (when (odd? count)
        (set! result (%concat result string)))
      (%infix ">>=" count 1)
      (set! string (%concat string string)))
    result))

(define-function substring (string start #key end length)
  (cond
    ((and end length)
     (substring string start end: (min end (+ start length))))
    (end
     (. string (substring start end)))
    (length
     (. string (substr start length)))
    (else:
     (. string (substring start)))))

(define-function expression? (form)
  (and (instance? form <array>)
       (instance? (first form)
                  <symbol>)))