Fix indentation.

Fix indentation.

(ns wisp.backend.escodegen.writer
  (:require [wisp.reader :refer [read-from-string]]
            [wisp.ast :refer [meta with-meta symbol? symbol keyword? keyword
                              namespace unquote? unquote-splicing? quote?
                              syntax-quote? name gensym pr-str]]
            [wisp.sequence :refer [empty? count list? list first second third
                                   rest cons conj butlast reverse reduce vec
                                   last map filter take concat partition
                                   repeat interleave]]
            [wisp.runtime :refer [odd? dictionary? dictionary merge keys vals
                                  contains-vector? map-dictionary string?
                                  number? vector? boolean? subs re-find true?
                                  false? nil? re-pattern? inc dec str char
                                  int = ==]]
            [wisp.string :refer [split join upper-case replace]]
            [wisp.expander :refer [install-macro!]]
            [escodegen :refer [generate]]))

;; Define unique character that is valid JS identifier that will
;; be used in generated symbols to avoid conflicts
;; http://www.fileformat.info/info/unicode/char/141d/index.htm
(def **unique-char** "ᐝ")

(defn ->camel-join
  [prefix key]
  (str prefix
       (if (and (not (empty? prefix))
                (not (empty? key)))
         (str (upper-case (get key 0)) (subs key 1))
         key)))

(defn translate-identifier-word
  "Translates references from clojure convention to JS:

  **macros**      __macros__
  list->vector    listToVector
  set!            set
  foo_bar         foo_bar
  number?         isNumber
  red=            redEqual
  create-server   createServer"
  [form]
  (def id (name form))
  (set! id (cond (identical? id  "*") "multiply"
                 (identical? id "/") "divide"
                 (identical? id "+") "sum"
                 (identical? id "-") "subtract"
                 (identical? id "=") "equal?"
                 (identical? id "==") "strict-equal?"
                 (identical? id "<=") "not-greater-than"
                 (identical? id ">=") "not-less-than"
                 (identical? id ">") "greater-than"
                 (identical? id "<") "less-than"
                 :else id))

  ;; **macros** ->  __macros__
  (set! id (join "_" (split id "*")))
  ;; list->vector ->  listToVector
  (set! id (join "-to-" (split id "->")))
  ;; set! ->  set
  (set! id (join (split id "!")))
  (set! id (join "$" (split id "%")))
  (set! id (join "-equal-" (split id "=")))
  ;; foo= -> fooEqual
  ;(set! id (join "-equal-" (split id "="))
  ;; foo+bar -> fooPlusBar
  (set! id (join "-plus-" (split id "+")))
  (set! id (join "-and-" (split id "&")))
  ;; number? -> isNumber
  (set! id (if (identical? (last id) "?")
             (str "is-" (subs id 0 (dec (count id))))
             id))
  ;; create-server -> createServer
  (set! id (reduce ->camel-join "" (split id "-")))
  id)

(defn translate-identifier
  [form]
  (join \. (map translate-identifier-word (split (name form) \.))))

(defn error-arg-count
  [callee n]
  (throw (SyntaxError (str "Wrong number of arguments (" n ") passed to: " callee))))

(defn write-location
  [form]
  (let [data (meta form)
        start (:start data)
        end (:end data)]
    (if (not (nil? start))
      {:start {:line (inc (:line start))
               :column (:column start)}
       :end {:line (inc (:line end))
             :column (inc (:column end))}})))

(def **writers** {})
(defn install-writer!
  [op writer]
  (set! (get **writers** op) writer))

(defn write-op
  [op form]
  (let [writer (get **writers** op)]
    (assert writer (str "Unsupported operation: " op))
    (conj {:loc (write-location (:form form))}
          (writer form))))

(def **specials** {})
(defn install-special!
  [op writer]
  (set! (get **specials** (name op)) writer))

(defn write-special
  [writer form]
  (conj {:loc (write-location (:form form))}
        (apply writer (:params form))))

(defn write-nil
  [form]
  {:type :UnaryExpression
   :operator :void
   :argument {:type :Literal
              :value 0}
   :prefix true})
(install-writer! :nil write-nil)

(defn write-literal
  [form]
  {:type :Literal
   :value form})

(defn write-list
  [form]
  {:type :CallExpression
   :callee (write {:op :var
                   :form 'list})
   :arguments (map write (:items form))})
(install-writer! :list write-list)

(defn write-symbol
  [form]
  {:type :CallExpression
   :callee (write {:op :var
                   :form 'symbol})
   :arguments [(write-constant (:namespace form))
               (write-constant (:name form))]})
(install-writer! :symbol write-symbol)

(defn write-constant
  [form]
  (cond (nil? form) (write-nil form)
        (keyword? form) (write-keyword form)
        (number? form) (write-number form)
        :else (write-literal form)))
(install-writer! :constant #(write-constant (:form %)))

(defn write-number
  [form]
  (if (< form 0)
    {:type :UnaryExpression
     :operator :-
     :prefix true
     :argument (write-number (* form -1))}
    (write-literal form)))

(defn write-keyword
  [form]
  {:type :Literal
   :value (name form)})
(install-writer! :keyword write-keyword)

(defn ->identifier
  [form]
  {:type :Identifier
   :name (translate-identifier form)})

(defn write-binding-var
  [form]
  (let [id (name (:id form))]
    ;; If identifiers binding shadows other binding rename it according
    ;; to shadowing depth. This allows bindings initializer safely
    ;; access binding before shadowing it.
    (->identifier (if (:shadow form)
                    (str id **unique-char** (:depth form))
                    id))))

(defn write-var
  "handler for {:op :var} type forms. Such forms may
  represent references in which case they have :info
  pointing to a declaration :var which way be either
  function parameter (has :param true) or local
  binding declaration (has :binding true) like ones defined
  by let and loop forms in later case form will also have
  :shadow pointing to a declaration node it shadows and
  :depth property with a depth of shadowing, that is used
  to for renaming logic to avoid name collisions in forms
  like let that allow same named bindings."
  [node]
  (if (= :binding (:type (:binding node)))
    (write-binding-var (:binding node))
    (->identifier (name (:form node)))))
(install-writer! :var write-var)
(install-writer! :param write-var)

(defn write-invoke
  [form]
  {:type :CallExpression
   :callee (write (:callee form))
   :arguments (map write (:params form))})
(install-writer! :invoke write-invoke)

(defn write-vector
  [form]
  {:type :ArrayExpression
   :elements (map write (:items form))})
(install-writer! :vector write-vector)

(defn write-dictionary
  [form]
  (let [properties (partition 2 (interleave (:keys form)
                                            (:values form)))]
    {:type :ObjectExpression
     :properties (map (fn [pair]
                        (let [key (first pair)
                              value (second pair)]
                          {:kind :init
                           :type :Property
                           :key (if (= :symbol (:op key))
                                  (write-constant (str (:form key)))
                                  (write key))
                           :value (write value)}))
                      properties)}))
(install-writer! :dictionary write-dictionary)

(defn write-export
  [form]
  (write {:op :set!
          :target {:op :member-expression
                   :computed false
                   :target {:op :var
                            :form 'exports}
                   :property (:id form)}
          :value (:init form)}))

(defn write-def
  [form]
  {:type :VariableDeclaration
   :kind :var
   :declarations [{:type :VariableDeclarator
                   :id (write (:id form))
                   :init (if (:export form)
                           (write-export form)
                           (write (:init form)))}]})
(install-writer! :def write-def)

(defn write-binding
  [form]
  {:type :VariableDeclaration
   :kind :var
   :declarations [{:type :VariableDeclarator
                   :id (write-binding-var form)
                   :init (write (:init form))}]})
(install-writer! :binding write-binding)

(defn write-throw
  [form]
  (->expression {:type :ThrowStatement
                 :argument (write (:throw form))}))
(install-writer! :throw write-throw)

(defn write-new
  [form]
  {:type :NewExpression
   :callee (write (:constructor form))
   :arguments (map write (:params form))})
(install-writer! :new write-new)

(defn write-set!
  [form]
  {:type :AssignmentExpression
   :operator :=
   :left (write (:target form))
   :right (write (:value form))})
(install-writer! :set! write-set!)

(defn write-aget
  [form]
  {:type :MemberExpression
   :computed (:computed form)
   :object (write (:target form))
   :property (write (:property form))})
(install-writer! :member-expression write-aget)

;; Map of statement AST node that are generated
;; by a writer. Used to decet weather node is
;; statement or expression.
(def **statements** {:EmptyStatement true :BlockStatement true
                     :ExpressionStatement true :IfStatement true
                     :LabeledStatement true :BreakStatement true
                     :ContinueStatement true :SwitchStatement true
                     :ReturnStatement true :ThrowStatement true
                     :TryStatement true :WhileStatement true
                     :DoWhileStatement true :ForStatement true
                     :ForInStatement true :ForOfStatement true
                     :LetStatement true :VariableDeclaration true
                     :FunctionDeclaration true})

(defn write-statement
  "Wraps expression that can't be in a block statement
  body into :ExpressionStatement otherwise returns back
  expression."
  [form]
  (->statement (write form)))

(defn ->statement
  [node]
  (if (get **statements** (:type node))
    node
    {:type :ExpressionStatement
     :expression node}))

(defn write-body
  "Takes form that may contain `:statements` vector
  or `:result` form  and returns vector expression
  nodes that can be used in any block. If `:result`
  is present it will be a last in vector and of a
  `:ReturnStatement` type.
  Examples:

  (write-body {:statements nil
               :result {:op :constant
                        :type :number
                        :form 3}})
  ;; =>
  [{:type :ReturnStatement
    :argument {:type :Literal :value 3}}]

  (write-body {:statements [{:op :set!
                             :target {:op :var :form 'x}
                             :value {:op :var :form 'y}}]
               :result {:op :var :form 'x}})
  ;; =>
  [{:type :ExpressionStatement
    :expression {:type :AssignmentExpression
                 :operator :=
                 :left {:type :Identifier :name :x}
                 :right {:type :Identifier :name :y}}}
   {:type :ReturnStatement
    :argument {:type :Identifier :name :x}}]"
  [form]
  (let [statements (map write-statement
                        (or (:statements form) []))

        result (if (:result form)
                 {:type :ReturnStatement
                  :argument (write (:result form))})]

    (if result
      (conj statements result)
      statements)))

(defn ->block
  [body]
  {:type :BlockStatement
   :body (if (vector? body)
           body
           [body])})

(defn ->expression
  [body]
  {:type :CallExpression
   :arguments []
   :callee (->sequence [{:type :FunctionExpression
                         :id nil
                         :params []
                         :defaults []
                         :expression false
                         :generator false
                         :rest nil
                         :body (->block body)}])})

(defn write-do
  [form]
  (->expression (write-body form)))
(install-writer! :do write-do)

(defn write-if
  [form]
  {:type :ConditionalExpression
   :test (write (:test form))
   :consequent (write (:consequent form))
   :alternate (write (:alternate form))})
(install-writer! :if write-if)

(defn write-try
  [form]
  (let [handler (:handler form)
        finalizer (:finalizer form)]
    (->expression {:type :TryStatement
                   :guardedHandlers []
                   :block (->block (write-body (:body form)))
                   :handlers (if handler
                               [{:type :CatchClause
                                 :param (write (:name handler))
                                 :body (->block (write-body handler))}]
                               [])
                   :finalizer (cond finalizer (->block (write-body finalizer))
                                    (not handler) (->block [])
                                    :else nil)})))
(install-writer! :try write-try)

(defn- write-binding-value
  [form]
  (write (:init form)))

(defn- write-binding-param
  [form]
  (write-var {:form (:name form)}))

(defn write-binding
  [form]
  (write {:op :def
          :var form
          :init (:init form)
          :form form}))

(defn write-let
  [form]
  (let [body (conj form
                   {:statements (vec (concat
                                      (:bindings form)
                                      (:statements form)))})]
    (->iffe (->block (write-body body)))))
(install-writer! :let write-let)

(defn ->rebind
  [form]
  (loop [result []
         bindings (:bindings form)]
    (if (empty? bindings)
      result
      (recur (conj result
                   {:type :AssignmentExpression
                    :operator :=
                    :left (write-binding-var (first bindings))
                    :right {:type :MemberExpression
                            :computed true
                            :object {:type :Identifier
                                     :name :loop}
                            :property {:type :Literal
                                       :value (count result)}}})
             (rest bindings)))))

(defn ->sequence
  [expressions]
  {:type :SequenceExpression
   :expressions expressions})

(defn ->iffe
  [body id]
  {:type :CallExpression
   :arguments []
   :callee (->sequence [{:type :FunctionExpression
                         :id id
                         :params []
                         :defaults []
                         :expression false
                         :generator false
                         :rest nil
                         :body body}])})

(defn ->loop-init
  []
  {:type :VariableDeclaration
   :kind :var
   :declarations [{:type :VariableDeclarator
                   :id {:type :Identifier
                        :name :recur}
                   :init {:type :Identifier
                          :name :loop}}]})

(defn ->do-while
 [body test]
 {:type :DoWhileStatement
  :body body
  :test test})

(defn ->set!-recur
  [form]
  {:type :AssignmentExpression
   :operator :=
   :left {:type :Identifier :name :recur}
   :right (write form)})

(defn ->loop
  [form]
  (->sequence (conj (->rebind form)
                    {:type :BinaryExpression
                     :operator :===
                     :left {:type :Identifier
                            :name :recur}
                     :right {:type :Identifier
                             :name :loop}})))

(defn write-loop
  [form]
  (let [statements (:statements form)
        result (:result form)
        bindings (:bindings form)

        loop-body (conj (map write statements)
                        (->statement (->set!-recur result)))
        body (concat [(
                       ->loop-init)]
                     (map write bindings)
                     [(->do-while (->block (vec loop-body))
                                  (->loop form))]
                     [{:type :ReturnStatement
                       :argument {:type :Identifier
                                  :name :recur}}])]
    (->iffe (->block (vec body)) 'loop)))
(install-writer! :loop write-loop)

(defn ->recur
  [form]
  (loop [result []
         params (:params form)]
    (if (empty? params)
      result
      (recur (conj result
                   {:type :AssignmentExpression
                    :operator :=
                    :right (write (first params))
                    :left {:type :MemberExpression
                           :computed true
                           :object {:type :Identifier
                                    :name :loop}
                           :property {:type :Literal
                                      :value (count result)}}})
             (rest params)))))

(defn write-recur
  [form]
  (->sequence (conj (->recur form)
                    {:type :Identifier
                     :name :loop})))
(install-writer! :recur write-recur)

(defn fallback-overload
  []
  {:type :SwitchCase
   :test nil
   :consequent [{:type :ThrowStatement
                 :argument {:type :CallExpression
                            :callee {:type :Identifier
                                     :name :RangeError}
                            :arguments [{:type :Literal
                                         :value "Wrong number of arguments passed"}]}}]})

(defn splice-binding
  [form]
  {:op :def
   :id (last (:params form))
   :init {:op :invoke
          :callee {:op :var
                   :form 'Array.prototype.slice.call}
          :params [{:op :var
                    :form 'arguments}
                   {:op :constant
                    :form (:arity form)
                    :type :number}]}})

(defn write-overloading-params
  [params]
  (reduce (fn [forms param]
            (conj forms {:op :def
                         :id param
                         :init {:op :member-expression
                                :computed true
                                :target {:op :var
                                         :form 'arguments}
                                :property {:op :constant
                                           :type :number
                                           :form (count forms)}}}))
          []
          params))

(defn write-overloading-fn
  [form]
  (let [overloads (map write-fn-overload (:methods form))]
    {:params []
     :body (->block {:type :SwitchStatement
                     :discriminant {:type :MemberExpression
                                    :computed false
                                    :object {:type :Identifier
                                             :name :arguments}
                                    :property {:type :Identifier
                                               :name :length}}
                     :cases (if (:variadic form)
                              overloads
                              (conj overloads (fallback-overload)))})}))

(defn write-fn-overload
  [form]
  (let [params (:params form)
        bindings (if (:variadic form)
                   (conj (write-overloading-params (butlast params))
                         (splice-binding form))
                   (write-overloading-params params))
        statements (vec (concat bindings (:statements form)))]
    {:type :SwitchCase
     :test (if (not (:variadic form))
             {:type :Literal
              :value (:arity form)})
     :consequent (write-body (conj form {:statements statements}))}))

(defn write-simple-fn
  [form]
  (let [method (first (:methods form))
        params (if (:variadic method)
                 (butlast (:params method))
                 (:params method))
        body (if (:variadic method)
               (conj method
                     {:statements (vec (cons (splice-binding method)
                                             (:statements method)))})
               method)]
    {:params (map write-var params)
     :body (->block (write-body body))}))

(defn resolve
  [from to]
  (let [requirer (split (name from) \.)
        requirement (split (name to) \.)
        relative? (and (not (identical? (name from)
                                        (name to)))
                       (identical? (first requirer)
                                   (first requirement)))]
    (if relative?
      (loop [from requirer
             to requirement]
        (if (identical? (first from)
                        (first to))
          (recur (rest from) (rest to))
          (join \/
                (concat [\.]
                        (repeat (dec (count from)) "..")
                        to))))
      (join \/ requirement))))

(defn id->ns
  "Takes namespace identifier symbol and translates to new
  simbol without . special characters
  wisp.core -> wisp*core"
  [id]
  (symbol nil (join \* (split (name id) \.))))

(defn write-require
  [form requirer]
  (let [ns-binding {:op :def
                    :id {:op :var
                         :type :identifier
                         :form (id->ns (:ns form))}
                    :init {:op :invoke
                           :callee {:op :var
                                    :type :identifier
                                    :form 'require}
                           :params [{:op :constant
                                     :form (resolve requirer (:ns form))}]}}
        ns-alias (if (:alias form)
                   {:op :def
                    :id {:op :var
                         :type :identifier
                         :form (id->ns (:alias form))}
                    :init (:id ns-binding)})

        references (reduce (fn [references form]
                             (conj references
                                   {:op :def
                                    :id {:op :var
                                         :type :identifier
                                         :form (or (:rename form)
                                                   (:name form))}
                                    :init {:op :member-expression
                                           :computed false
                                           :target (:id ns-binding)
                                           :property {:op :var
                                                      :type :identifier
                                                      :form (:name form)}}}))
                           []
                           (:refer form))]
    (vec (cons ns-binding
               (if ns-alias
                 (cons ns-alias references)
                 references)))))

(defn write-ns
  [form]
  (let [requirer (:name form)
        ns-binding {:op :def
                    :id {:op :var
                         :type :identifier
                         :form '*ns*}
                    :init {:op :dictionary
                           :keys [{:op :var
                                   :type :identifier
                                   :form 'id}
                                  {:op :var
                                   :type :identifier
                                   :form 'doc}]
                           :values [{:op :constant
                                     :type :identifier
                                     :form (name (:name form))}
                                    {:op :constant
                                     :form (:doc form)}]}}
        requirements (vec (apply concat (map #(write-require % requirer)
                                             (:require form))))]
    (->block (map write (vec (cons ns-binding requirements))))))
(install-writer! :ns write-ns)

(defn write-fn
  [form]
  (let [base (if (> (count (:methods form)) 1)
               (write-overloading-fn form)
               (write-simple-fn form))]
    (conj base
          {:type :FunctionExpression
           :id (if (:id form) (write-var (:id form)))
           :defaults nil
           :rest nil
           :generator false
           :expression false})))
(install-writer! :fn write-fn)

(defn write
  [form]
  (let [op (:op form)
        writer (and (= :invoke (:op form))
                    (= :var (:op (:callee form)))
                    (get **specials** (name (:form (:callee form)))))]
    (if writer
      (write-special writer form)
      (write-op (:op form) form))))

(defn write*
  [& forms]
  (let [body (map write-statement forms)]
    {:type :Program
     :body body}))

(defn compile
  ([form] (compile {} form))
  ([options & forms] (generate (apply write* forms) options)))

(defn get-macro
  [target property]
  `(aget (or ~target 0)
         ~property))
(install-macro! :get get-macro)

;; Logical operators

(defn install-logical-operator!
  [callee operator fallback]
  (defn write-logical-operator
    [& operands]
    (let [n (count operands)]
      (cond (= n 0) (write-constant fallback)
            (= n 1) (write (first operands))
            :else (reduce (fn [left right]
                            {:type :LogicalExpression
                             :operator operator
                             :left left
                             :right (write right)})
                          (write (first operands))
                          (rest operands)))))
  (install-special! callee write-logical-operator))
(install-logical-operator! :or :|| nil)
(install-logical-operator! :and :&& true)

(defn install-unary-operator!
  [callee operator prefix?]
  (defn write-unary-operator
    [& params]
    (if (identical? (count params) 1)
      {:type :UnaryExpression
       :operator operator
       :argument (write (first params))
       :prefix prefix?}
      (error-arg-count callee (count params))))
  (install-special! callee write-unary-operator))
(install-unary-operator! :not :!)

;; Bitwise Operators

(install-unary-operator! :bit-not :~)

(defn install-binary-operator!
  [callee operator]
  (defn write-binary-operator
    [& params]
    (if (< (count params) 2)
      (error-arg-count callee (count params))
      (reduce (fn [left right]
                {:type :BinaryExpression
                 :operator operator
                 :left left
                 :right (write right)})
              (write (first params))
              (rest params))))
  (install-special! callee write-binary-operator))
(install-binary-operator! :bit-and :&)
(install-binary-operator! :bit-or :|)
(install-binary-operator! :bit-xor :^)
(install-binary-operator! :bit-shift-left :<<)
(install-binary-operator! :bit-shift-right :>>)
(install-binary-operator! :bit-shift-right-zero-fil :>>>)

;; Arithmetic operators

(defn install-arithmetic-operator!
  [callee operator valid? fallback]

  (defn write-binary-operator
    [left right]
    {:type :BinaryExpression
     :operator (name operator)
     :left left
     :right (write right)})

  (defn write-arithmetic-operator
    [& params]
    (let [n (count params)]
      (cond (and valid? (not (valid? n))) (error-arg-count (name callee) n)
            (== n 0) (write-literal fallback)
            (== n 1) (reduce write-binary-operator
                             (write-literal fallback)
                             params)
            :else (reduce write-binary-operator
                          (write (first params))
                          (rest params)))))

  (install-special! callee write-arithmetic-operator))

(install-arithmetic-operator! :+ :+ nil 0)
(install-arithmetic-operator! :- :- #(>= % 1) 0)
(install-arithmetic-operator! :* :* nil 1)
(install-arithmetic-operator! (keyword \/) (keyword \/) #(>= % 1) 1)
(install-arithmetic-operator! :mod (keyword \%) #(== % 2) 1)

;; Comparison operators

(defn install-comparison-operator!
  "Generates comparison operator writer that given one
  parameter writes `fallback` given two parameters writes
  binary expression and given more parameters writes binary
  expressions joined by logical and."
  [callee operator fallback]

  ;; TODO #54
  ;; Comparison operators must use temporary variable to store
  ;; expression non literal and non-identifiers.
  (defn write-comparison-operator
    ([] (error-arg-count callee 0))
    ([form] (->sequence [(write form)
                         (write-literal fallback)]))
    ([left right]
     {:type :BinaryExpression
      :operator operator
      :left (write left)
      :right (write right)})
    ([left right & more]
     (reduce (fn [left right]
               {:type :LogicalExpression
                :operator :&&
                :left left
                :right {:type :BinaryExpression
                        :operator operator
                        :left (if (= :LogicalExpression (:type left))
                                (:right (:right left))
                                (:right left))
                        :right (write right)}})
             (write-comparison-operator left right)
             more)))

  (install-special! callee write-comparison-operator))

(install-comparison-operator! :== :== true)
(install-comparison-operator! :> :> true)
(install-comparison-operator! :>= :>= true)
(install-comparison-operator! :< :< true)
(install-comparison-operator! :<= :<= true)

(defn write-identical?
  [& params]
  ;; TODO: Submit a bug for clojure to allow variadic
  ;; number of params joined by logical and.
  (if (identical? (count params) 2)
    {:type :BinaryExpression
     :operator :===
     :left (write (first params))
     :right (write (second params))}
    (error-arg-count :identical? (count params))))
(install-special! :identical? write-identical?)

(defn write-instance?
  [& params]
  ;; TODO: Submit a bug for clojure to make sure that
  ;; instance? either accepts only two args or returns
  ;; true only if all the params are instance of the
  ;; given type.

  (let [constructor (first params)
        instance (second params)]
    (if (< (count params) 1)
      (error-arg-count :instance? (count params))
      {:type :BinaryExpression
       :operator :instanceof
       :left (if instance
               (write instance)
               (write-constant instance))
       :right (write constructor)})))
(install-special! :instance? write-instance?)

(defn expand-apply
  [f & params]
  (let [prefix (vec (butlast params))]
    (if (empty? prefix)
      `(.apply ~f nil ~@params)
      `(.apply ~f nil (.concat ~prefix ~(last params))))))
(install-macro! :apply expand-apply)

(defn expand-print
  [& more]
  "Prints the object(s) to the output for human consumption."
  `(.log console ~@more))
(install-macro! :print expand-print)

(defn expand-str
  "str inlining and optimization via macros"
  [& forms]
  `(+ "" ~@forms))
(install-macro! :str expand-str)

(defn expand-debug
  []
  'debugger)
(install-macro! :debugger! expand-debug)


Initial draft of method overload support for functions.

(import [read-from-string] "./reader")
(import [meta with-meta symbol? symbol keyword? keyword
         unquote? unquote-splicing? quote? syntax-quote? name gensym] "./ast")
(import [empty? count list? list first second third rest cons
         reverse map-list concat-list reduce-list list-to-vector] "./list")
(import [odd? dictionary? dictionary merge keys vals contains-vector?
         map-dictionary string? number? vector? boolean?
         true? false? nil? re-pattern? inc dec str] "./runtime")

(defn ^boolean self-evaluating?
  "Returns true if form is self evaluating"
  [form]
  (or (number? form)
      (and (string? form)
           (not (symbol? form))
           (not (keyword? form)))
      (boolean? form)
      (nil? form)
      (re-pattern? form)))

;; Macros

(def __macros__ {})

(defn execute-macro
  "Applies macro registered with given `name` to a given `form`"
  [name form]
  (apply (get __macros__ name)
         (list-to-vector form)))

(defn install-macro
  "Registers given `macro` with a given `name`"
  [name macro-fn]
  (set! (get __macros__ name) macro-fn))

(defn macro?
  "Returns true if macro with a given name is registered"
  [name]
  (and (symbol? name)
       (get __macros__ name)
       true))

(defn make-macro
  "Makes macro"
  [pattern body]
  (let [macro-fn `(fn ~pattern ~@body)]
        ;; compile the macro into native code and use the host's native
        ;; eval to eval it into a function.
        (eval (str "(" (compile (macroexpand macro-fn)) ")"))))

(install-macro
 'defmacro
 (fn
  "Like defn, but the resulting function name is declared as a
  macro and will be used as a macro by the compiler when it is
  called."
  [name signature & body]
  (install-macro name (make-macro signature body))))

;; special forms
;;
;; special forms are like macros for generating source code. It allows the
;; generator to customize how certain forms look in the final output.
;; these could have been macros that expand into basic forms, but we
;; want readable output. Special forms are responsible for integrity
;; checking of the form.

(def __specials__ {})

(defn install-special
  "Installs special function"
  [name f validator]
  (set! (get __specials__ name)
        (fn [form]
          (if validator (validator form))
          (f (rest form)))))

(defn special?
  "Returns true if special form"
  [name]
  (and (symbol? name)
       (get __specials__ name)
       true))

(defn execute-special
  "Expands special form"
  [name form]
  ((get __specials__ name) form))

(defn opt [argument fallback]
  (if (or (nil? argument) (empty? argument)) fallback (first argument)))

(defn apply-form
  "Take a form that has a list of children and make a form that
  applies the children to the function `fn-name`"
  [fn-name form quoted?]
  (cons fn-name
        (if quoted?
            (map-list form (fn [e] (list 'quote e))) form)
            form))

(defn apply-unquoted-form
  "Same as apply-form, but respect unquoting"
  [fn-name form]
  (cons fn-name ;; ast.prepend ???
        (map-list
          form
          (fn [e]
              (if (unquote? e)
                  (second e)
                  (if (and (list? e)
                           (keyword? (first e)))
                      (list 'syntax-quote (second e))
                      (list 'syntax-quote e)))))))

(defn split-splices
  ""
  [form fn-name]

  (defn make-splice
    ""
    [form]
    (if (or (self-evaluating? form)
            (symbol? form))
        (apply-unquoted-form fn-name (list form))
        (apply-unquoted-form fn-name form)))

  (loop [nodes form
         slices '()
         acc '()]
   (if (empty? nodes)
       (reverse
        (if (empty? acc)
            slices
            (cons (make-splice (reverse acc)) slices)))
       (let [node (first nodes)]
        (if (unquote-splicing? node)
            (recur (rest nodes)
                   (cons (second node)
                         (if (empty? acc)
                             slices
                             (cons (make-splice (reverse acc)) slices)))
                   '())
            (recur (rest nodes)
                   slices
                   (cons node acc)))))))

(defn syntax-quote-split
  [append-name fn-name form]
  (let [slices (split-splices form fn-name)]
    (if (= (count slices) 1)
      (first slices)
      (apply-form append-name slices))))

;; compiler

(defn compile-object
  ""
  [form quoted?]
  ;; TODO: Add regexp to the list.
  (cond
    (keyword? form) (compile-keyword form)
    (symbol? form) (compile-symbol form)
    (number? form) (compile-number form)
    (string? form) (compile-string form)
    (boolean? form) (compile-boolean form)
    (nil? form) (compile-nil form)
    (re-pattern? form) (compile-re-pattern form)
    (vector? form) (compile (apply-form 'vector
                                        (apply list form)
                                        quoted?))
    (list? form) (compile (apply-form 'list
                                      form
                                      quoted?))
    (dictionary? form) (compile-dictionary
                        (if quoted?
                          (map-dictionary form (fn [x] (list 'quote x)))
                          form))))

(defn compile-reference
  "Translates references from clojure convention to JS:

  **macros**      __macros__
  list->vector    listToVector
  set!            set
  foo_bar         foo_bar
  number?         isNumber
  create-server   createServer"
  [form]
  (def id (name form))
  ;; **macros** ->  __macros__
  (set! id (.join (.split id "*") "_"))
  ;; list->vector ->  listToVector
  (set! id (.join (.split id "->") "-to-"))
  ;; set! ->  set
  (set! id (.join (.split id "!") ""))
  (set! id (.join (.split id "%") "$"))
  ;; number? -> isNumber
  (set! id (if (identical? (.substr id -1) "?")
             (str "is-" (.substr id 0 (- (.-length id) 1)))
             id))
  ;; create-server -> createServer
  (set! id (.reduce
            (.split id "-")
            (fn [result key]
              (str result
                   (if (and (not (empty? result))
                            (not (empty? key)))
                     (str (.to-upper-case (get key 0)) (.substr key 1))
                     key)))
            ""))
  id)

(defn compile-keyword-reference
  [form]
  (str "\"" (name form) "\""))

(defn compile-syntax-quoted
  ""
  [form]
  (cond
   (list? form) (compile (syntax-quote-split 'concat-list 'list form))
   (vector? form)
    (compile (syntax-quote-split 'concat-vector 'vector (apply list form)))
   (dictionary? form) (compile (syntax-quote-split 'merge 'dictionary form))
   :else (compile-object form)))

(defn compile
  "compiles given form"
  [form]
  (cond
   (self-evaluating? form) (compile-object form)
   (symbol? form) (compile-reference form)
   (keyword? form) (compile-keyword-reference form)
   (vector? form) (compile-object form)
   (dictionary? form) (compile-object form)
   (list? form)
    (let [head (first form)]
      (cond
       (quote? form) (compile-object (second form) true)
       (syntax-quote? form) (compile-syntax-quoted (second form))
       (special? head) (execute-special head form)
       ;; Compile keyword invoke as a property access.
       (keyword? head) (compile (list 'get (second form) head))
       :else (do
              (if (not (or (symbol? head) (list? head)))
                (throw (compiler-error
                        form
                        (str "operator is not a procedure: " head)))
              (compile-invoke form)))))))

(defn compile-program
  "compiles all expansions"
  [forms]
  (loop [result ""
         expressions forms]
    (if (empty? expressions)
      result
      (recur
        (str result
             (if (empty? result) "" ";\n\n")
             (compile (macroexpand (first expressions))))
        (rest expressions)))))

(defn macroexpand-1
  "If form represents a macro form, returns its expansion,
  else returns form."
  [form]
  (if (list? form)
    (let [op (first form)
          id (name op)]
      (cond
        (special? op) form
        (macro? op) (execute-macro op (rest form))
        (and (symbol? op)
             (not (identical? id ".")))
          ;; (.substring s 2 5) => (. s substring 2 5)
          (if (identical? (.char-at id 0) ".")
            (if (< (count form) 2)
              (throw (Error
                "Malformed member expression, expecting (.member target ...)"))
              (cons '.
                    (cons (second form)
                          (cons (symbol (.substr id 1))
                                (rest (rest form))))))

            ;; (StringBuilder. "foo") => (new StringBuilder "foo")
            (if (identical? (.char-at id (- (.-length id) 1)) ".")
              (cons 'new
                    (cons (symbol (.substr id 0 (- (.-length id) 1)))
                          (rest form)))
              form))
        :else form))
      form))

(defn macroexpand
  "Repeatedly calls macroexpand-1 on form until it no longer
  represents a macro form, then returns it."
  [form]
  (loop [original form
         expanded (macroexpand-1 form)]
    (if (identical? original expanded)
      original
      (recur expanded (macroexpand-1 expanded)))))

;; backend specific compiler hooks

(defn compile-template
  "Compiles given template"
  [form]
  (def indent-pattern #"\n *$")
  (def line-break-patter (RegExp "\n" "g"))
  (defn get-indentation [code]
    (let [match (.match code indent-pattern)]
      (or (and match (get match 0)) "\n")))

  (loop [code ""
         parts (.split (first form) "~{}")
         values (rest form)]
    (if (> (.-length parts) 1)
      (recur
       (str
        code
        (get parts 0)
        (.replace (str "" (first values))
                  line-break-patter
                  (get-indentation (get parts 0))))
       (.slice parts 1)
       (rest values))
       (.concat code (get parts 0)))))

(defn compile-def
  "Creates and interns or locates a global var with the name of symbol
  and a namespace of the value of the current namespace (*ns*). If init
  is supplied, it is evaluated, and the root binding of the var is set
  to the resulting value. If init is not supplied, the root binding of
  the var is unaffected. def always applies to the root binding, even if
  the var is thread-bound at the point where def is called. def yields
  the var itself (not its value)."
  [form]
  (compile-template
   (list "var ~{}"
         (compile (cons 'set! form)))))

(defn compile-if-else
  "Evaluates test. If not the singular values nil or false,
  evaluates and yields then, otherwise, evaluates and yields else.
  If else is not supplied it defaults to nil. All of the other
  conditionals in Clojure are based upon the same logic, that is,
  nil and false constitute logical falsity, and everything else
  constitutes logical truth, and those meanings apply throughout."
  [form]
  (let [condition (macroexpand (first form))
        then-expression (macroexpand (second form))
        else-expression (macroexpand (third form))]
    (compile-template
      (list
        (if (and (list? else-expression)
                 (identical? (first else-expression) 'if))
          "~{} ?\n  ~{} :\n~{}"
          "~{} ?\n  ~{} :\n  ~{}")
        (compile condition)
        (compile then-expression)
        (compile else-expression)))))

(defn compile-dictionary
  "Compiles dictionary to JS object"
  [form]
  (let [body
        (loop [body nil
               names (keys form)]
          (if (empty? names)
            body
            (recur
             (str
              (if (nil? body) "" (str body ",\n"))
              (compile-template
               (list
                "~{}: ~{}"
                (compile (first names))
                (compile (macroexpand
                          (get form (first names)))))))
             (rest names))))
        ]
      (if (nil? body) "{}" (compile-template (list "{\n  ~{}\n}" body)))))

(defn desugar-fn-name [form]
  (if (symbol? (first form)) form (cons nil form)))

(defn desugar-fn-doc [form]
  (if (string? (second form))
    form
    (cons (first form) ;; (name nil ... )
          (cons nil (rest form)))))

(defn desugar-fn-attrs [form]
  (if (dictionary? (third form))
    form
    (cons (first form) ;; (name nil ... )
          (cons (second form)
            (cons nil (rest (rest form)))))))

(defn desugar-body [form]
  (if (list? (third form))
    form
    (with-meta
     (cons (first form)
           (cons (second form)
                 (list (rest (rest form)))))
     (meta (third form)))))

(defn compile-fn-params
  ;"compiles function params"
  [params]
  (if (contains-vector? params '&)
    (.join (.map (.slice params 0 (.index-of params '&)) compile) ", ")
    (.join (.map params compile) ", ")))

(defn compile-desugared-fn
  ;"(fn name? [params* ] exprs*)

  ;Defines a function (fn)"
  [name doc attrs params body]
  (compile-template
    (if (nil? name)
      (list "function(~{}) {\n  ~{}\n}"
            (compile-fn-params params)
            (compile-fn-body body params))
      (list "function ~{}(~{}) {\n  ~{}\n}"
            (compile name)
            (compile-fn-params params)
            (compile-fn-body body params)))))

(defn compile-statements
  [form prefix]
  (loop [result ""
         expression (first form)
         expressions (rest form)]
    (if (empty? expressions)
      (str result
           (if (nil? prefix) "" prefix)
           (compile (macroexpand expression))
           ";")
      (recur
        (str result (compile (macroexpand expression)) ";\n")
        (first expressions)
        (rest expressions)))))

(defn compile-fn-body
  [form params]
  (if (and (vector? params) (contains-vector? params '&))
    (compile-statements
      (cons (list 'def
                  (get params (inc (.index-of params '&)))
                  (list
                    'Array.prototype.slice.call
                    'arguments
                    (.index-of params '&)))
      form)
      "return ")
    (compile-statements form "return ")))

(defn compile-fn
  "(fn name? [params* ] exprs*)

  Defines a function (fn)"
  [form]
  (let [signature (desugar-fn-attrs (desugar-fn-doc (desugar-fn-name form)))
        name (first signature)
        doc (second signature)
        attrs (third signature)
        params (third (rest signature))
        body (rest (rest (rest (rest signature))))]
    (compile-desugared-fn name doc attrs params body)))

(defn compile-invoke
  [form]
  (compile-template
   ;; Wrap functions returned by expressions into parenthesis.
   (list (if (list? (first form)) "(~{})(~{})" "~{}(~{})")
         (compile (first form))
         (compile-group (rest form)))))

(defn compile-group
  [form wrap]
  (if wrap
    (str "(" (compile-group form) ")")
    (.join (list-to-vector
            (map-list (map-list form macroexpand) compile)) ", ")))

(defn compile-do
  "Evaluates the expressions in order and returns the value of the last.
  If no expressions are supplied, returns nil."
  [form]
  (compile (list (cons 'fn (cons [] form)))))

(defn define-bindings
  "Returns list of binding definitions"
  [form]
  (loop [defs '()
         bindings form]
    (if (= (count bindings) 0)
      (reverse defs)
      (recur
        (cons
          (list 'def                ; '(def (get bindings 0) (get bindings 1))
                (get bindings 0)    ; binding name
                (get bindings 1))   ; binding value
           defs)
        (rest (rest bindings))))))

(defn compile-let
  "Evaluates the exprs in a lexical context in which the symbols in
  the binding-forms are bound to their respective init-exprs or parts
  therein."
  ; {:added "1.0", :special-form true, :forms '[(let [bindings*] exprs*)]}
  [form]
  ;; TODO: Implement destructure for bindings:
  ;; https://github.com/clojure/clojure/blob/master/src/clj/clojure/core.clj#L3937
  ;; Consider making let a macro:
  ;; https://github.com/clojure/clojure/blob/master/src/clj/clojure/core.clj#L3999
  (compile
    (cons 'do
          (concat-list
            (define-bindings (first form))
            (rest form)))))

(defn compile-throw
  "The expression is evaluated and thrown, therefore it should yield an error."
  [form]
  (compile-template
    (list "(function() { throw ~{}; })()"
          (compile (macroexpand (first form))))))

(defn compile-set
  "Assignment special form.

  When the first operand is a field member access form, the assignment
  is to the corresponding field."
  ; {:added "1.0", :special-form true, :forms '[(loop [bindings*] exprs*)]}
  [form]
  (compile-template
    (list "~{} = ~{}"
      (compile (macroexpand (first form)))
      (compile (macroexpand (second form))))))

(defn compile-vector
  "Creates a new vector containing the args"
  [form]
  (compile-template (list "[~{}]" (compile-group form))))

(defn compile-try
  "The exprs are evaluated and, if no exceptions occur, the value
  of the last is returned. If an exception occurs and catch clauses
  are provided, its exprs are evaluated in a context in which name is
  bound to the thrown exception, and the value of the last is the return
  value of the function. If there is no matching catch clause, the exception
  propagates out of the function. Before returning, normally or abnormally,
  any finally exprs will be evaluated for their side effects."
  [form]
  (loop [try-exprs '()
         catch-exprs '()
         finally-exprs '()
         exprs (reverse form)]
    (if (empty? exprs)
      (if (empty? catch-exprs)
        (compile-template
          (list
            "(function() {\ntry {\n  ~{}\n} finally {\n  ~{}\n}})()"
            (compile-fn-body try-exprs)
            (compile-fn-body finally-exprs)))
        (if (empty? finally-exprs)
          (compile-template
            (list
              "(function() {\ntry {\n  ~{}\n} catch (~{}) {\n  ~{}\n}})()"
              (compile-fn-body try-exprs)
              (compile (first catch-exprs))
              (compile-fn-body (rest catch-exprs))))
          (compile-template
            (list
              "(function() {\ntry {\n  ~{}\n} catch (~{}) {\n  ~{}\n} finally {\n  ~{}\n}})()"
              (compile-fn-body try-exprs)
              (compile (first catch-exprs))
              (compile-fn-body (rest catch-exprs))
              (compile-fn-body finally-exprs)))))
        (if (identical? (first (first exprs)) 'catch)
          (recur try-exprs
                 (rest (first exprs))
                 finally-exprs
                 (rest exprs))
          (if (identical? (first (first exprs)) 'finally)
            (recur try-exprs
                   catch-exprs
                   (rest (first exprs))
                   (rest exprs))
            (recur (cons (first exprs) try-exprs)
                   catch-exprs
                   finally-exprs
                   (rest exprs)))))))

(defn compile-property
  "(. object method arg1 arg2)

  The '.' special form that can be considered to be a method call,
  operator"
  [form]
  ;; (. object method arg1 arg2) -> (object.method arg1 arg2)
  ;; (. object -property) -> object.property
  (if (identical? (aget (name (second form)) 0) "-")
    (compile-template
      (list (if (list? (first form)) "(~{}).~{}" "~{}.~{}")
            (compile (macroexpand (first form)))
            (compile (macroexpand (symbol (.substr (name (second form)) 1))))))
    (compile-template
      (list "~{}.~{}(~{})"
            (compile (macroexpand (first form)))    ;; object name
            (compile (macroexpand (second form)))   ;; method name
            (compile-group (rest (rest form)))))))  ;; args

(defn compile-apply
  [form]
  (compile
    (list '.
          (first form)
          'apply
          (first form)
          (second form))))

(defn compile-new
  "(new Classname args*)
  Compiles new special form. The args, if any, are evaluated
  from left to right, and passed to the constructor of the
  class named by Classname. The constructed object is returned."
  ; {:added "1.0", :special-form true, :forms '[(new Classname args*)]}
  [form]
  (compile-template (list "new ~{}" (compile form))))

(defn compile-compound-accessor
  "Compiles compound property accessor"
  [form]
  (compile-template
    (list "~{}[~{}]"
          (compile (macroexpand (first form)))
          (compile (macroexpand (second form))))))

(defn compile-instance
  "Evaluates x and tests if it is an instance of the class
  c. Returns true or false"
  [form]
  (compile-template (list "~{} instanceof ~{}"
                          (compile (macroexpand (second form)))
                          (compile (macroexpand (first form))))))

(defn compile-not
  "Returns true if x is logical false, false otherwise."
  [form]
  (compile-template (list "!(~{})" (compile (macroexpand (first form))))))

(defn compile-loop
  "Evaluates the body in a lexical context in which the symbols
  in the binding-forms are bound to their respective
  initial-expressions or parts therein. Acts as a recur target."
  [form]
  (let [bindings (apply dictionary (first form))
        names (keys bindings)
        values (vals bindings)
        body (rest form)]
    ;; `((fn loop []
    ;;    ~@(define-bindings bindings)
    ;;    ~@(compile-recur body names)))
    (compile
      (cons (cons 'fn
              (cons 'loop
                (cons names
                  (compile-recur names body))))
            (apply list values)))))

(defn rebind-bindings
  "Rebinds given bindings to a given names in a form of
  (set! foo bar) expressions"
  [names values]
  (loop [result '()
         names names
         values values]
    (if (empty? names)
      (reverse result)
      (recur
       (cons (list 'set! (first names) (first values)) result)
       (rest names)
       (rest values)))))

(defn expand-recur
  "Expands recur special form into params rebinding"
  [names body]
  (map-list body
       (fn [form]
         (if (list? form)
           (if (identical? (first form) 'recur)
             (list 'raw*
                   (compile-group
                    (concat-list
                      (rebind-bindings names (rest form))
                      (list 'loop))
                    true))
             (expand-recur names form))
           form))))

(defn compile-recur
  "Eliminates tail calls in form of recur and rebinds the bindings
  of the recursion point to the parameters of the recur"
  [names body]
  (list
    (list 'raw*
          (compile-template
          (list "var recur = loop;\nwhile (recur === loop) {\n  recur = ~{}\n}"
                (compile-statements (expand-recur names body)))))
    'recur))

(defn compile-raw
  "returns form back since it's already compiled"
  [form]
  (first form))

(install-special 'set! compile-set)
(install-special 'get compile-compound-accessor)
(install-special 'aget compile-compound-accessor)
(install-special 'def compile-def)
(install-special 'if compile-if-else)
(install-special 'do compile-do)
(install-special 'do* compile-statements)
(install-special 'fn compile-fn)
(install-special 'let compile-let)
(install-special 'throw compile-throw)
(install-special 'vector compile-vector)
(install-special 'try compile-try)
(install-special '. compile-property)
(install-special 'apply compile-apply)
(install-special 'new compile-new)
(install-special 'instance? compile-instance)
(install-special 'not compile-not)
(install-special 'loop compile-loop)
(install-special 'raw* compile-raw)

(defn compile-keyword [form] (str "\"" "\uA789" (name form) "\""))
(defn compile-symbol [form] (str "\"" "\uFEFF" (name form) "\""))
(defn compile-nil [form] "void(0)")
(defn compile-number [form] form)
(defn compile-boolean [form] (if (true? form) "true" "false"))
(defn compile-string
  [form]
  (set! form (.replace form (RegExp "\\\\" "g") "\\\\"))
  (set! form (.replace form (RegExp "\n" "g") "\\n"))
  (set! form (.replace form (RegExp "\r" "g") "\\r"))
  (set! form (.replace form (RegExp "\t" "g") "\\t"))
  (set! form (.replace form (RegExp "\"" "g") "\\\""))
  (str "\"" form "\""))

(defn compile-re-pattern
  [form]
  (str form))

(defn install-native
  "Creates an adapter for native operator"
  [alias operator validator fallback]
  (install-special
   alias
   (fn [form]
    (reduce-list
      (map-list form
                (fn [operand]
                  (compile-template
                    (list (if (list? operand) "(~{})" "~{}")
                      (compile (macroexpand operand))))))
      (fn [left right]
        (compile-template
          (list "~{} ~{} ~{}"
                left
                (name operator)
                right)))
      (if (empty? form) fallback nil)))
    validator))

(defn install-operator
  "Creates an adapter for native operator that does comparison in
  monotonical order"
  [alias operator]
  (install-special
   alias
   (fn [form]
    (loop [result ""
           left (first form)
           right (second form)
           operands (rest (rest form))]
      (if (empty? operands)
        (str result
             (compile-template (list "~{} ~{} ~{}"
                                     (compile (macroexpand left))
                                     (name operator)
                                     (compile (macroexpand right)))))
        (recur
          (str result
              (compile-template (list "~{} ~{} ~{} && "
                                      (compile (macroexpand left))
                                      (name operator)
                                      (compile (macroexpand right)))))
          right
          (first operands)
          (rest operands)))))
   verify-two))

(defn compiler-error
  [form message]
  (let [error (Error (str message))]
    (set! error.line 1)
    (throw error)))

(defn verify-two
  [form]
  (if (or (empty? (rest form))
          (empty? (rest (rest form))))
    (throw
      (compiler-error
        form
        (str (first form) " form requires at least two operands")))))

;; Arithmetic Operators
(install-native '+ '+ nil 0)
(install-native '- '- nil "NaN")
(install-native '* '* nil 1)
(install-native '/ '/ verify-two)
(install-native 'mod (symbol "%") verify-two)

;; Logical Operators
(install-native 'and '&&)
(install-native 'or '||)

;; Comparison Operators

(install-operator '= '==)
(install-operator 'not= '!=)
(install-operator '== '==)
(install-operator 'identical? '===)
(install-operator '> '>)
(install-operator '>= '>=)
(install-operator '< '<)
(install-operator '<= '<=)

;; Bitwise Operators

(install-native 'bit-and '& verify-two)
(install-native 'bit-or '| verify-two)
(install-native 'bit-xor (symbol "^"))
(install-native 'bit-not (symbol "~") verify-two)
(install-native 'bit-shift-left '<< verify-two)
(install-native 'bit-shift-right '>> verify-two)
(install-native 'bit-shift-right-zero-fil '>>> verify-two)

(install-macro
 'cond
 (fn cond
   "Takes a set of test/expr pairs. It evaluates each test one at a
   time.  If a test returns logical true, cond evaluates and returns
   the value of the corresponding expr and doesn't evaluate any of the
   other tests or exprs. (cond) returns nil."
   {:added "1.0"}
   [& clauses]
   (if (not (empty? clauses))
     (list 'if (first clauses)
           (if (empty? (rest clauses))
             (throw (Error "cond requires an even number of forms"))
             (second clauses))
           (cons 'cond (rest (rest clauses)))))))

(install-macro
 'defn
 (fn defn
   "Same as (def name (fn [params* ] exprs*)) or
   (def name (fn ([params* ] exprs*)+)) with any doc-string or attrs added
   to the var metadata"
   {:added "1.0" :special-form true }
   [name & body]
   `(def ~name (fn ~name ~@body))))

(install-macro
 'assert
 (fn assert
   "Evaluates expr and throws an exception if it does not evaluate to
   logical true."
   {:added "1.0"}
   [x message]
   (if (nil? message)
     `(assert ~x "")
     `(if (not ~x)
        (throw (Error. (.concat "Assert failed: " ~message "\n" '~x)))))))

(install-macro
 'export
 (fn
   "Helper macro for exporting multiple / single value"
   [& names]
   (if (empty? names)
     nil
     (if (empty? (rest names))
       `(set! module.exports ~(first names))
       (loop [form '() exports names]
         (if (empty? exports)
           `(do* ~@form)
           (recur (cons `(set!
                          (~(symbol (str ".-" (name (first exports))))
                            exports)
                          ~(first exports))
                        form)
                  (rest exports))))))))

(install-macro
 'import
 (fn
   "Helper macro for importing node modules"
   [imports path]
   (if (nil? path)
     `(require ~imports)
     (if (symbol? imports)
       `(def ~imports (require ~path))
       (loop [form '() names imports]
         (if (empty? names)
           `(do* ~@form)
           (let [alias (first names)
                 id (symbol (str ".-" (name alias)))]
             (recur (cons `(def ~alias
                             (~id (require ~path))) form)
                    (rest names)))))))))
;; TODO:
;; - alength
;; - defn with metadata in front of name
;; - declare

(defn map
  [f sequence]
  (if (vector? sequence)
    (map-vector f sequence)
    (map-list2 f sequence)))

(defn map-vector
  [f sequence]
  (.map sequence f))

(defn map-list2
  [f sequence]
  (loop [result '()
         items sequence]
    (if (empty? items)
      (reverse result)
      (recur (cons (f (first items) result) (rest items))))))

(defn filter
  [f sequence]
  (if (vector? sequence)
    (filter-vector f sequence)
    (filter-list f sequence)))

(defn filter-vector
  [f vector]
  (.filter vector f))

(defn filter-list
  [f? list]
  (loop [result '()
         items list]
    (if (empty? items)
      (reverse result)
      (recur (if (f? (first items))
              (cons (first items) result)
              result)
              (rest items)))))

(defn take-vector
  [n vector]
  (.slice vector 0 n))

(defn take-list
  [n list]
  (loop [taken '()
         items list
         n n]
    (if (or (= n 0) (empty? items))
      (reverse taken)
      (recur (cons (first items) taken)
             (rest items)
             (dec n)))))

(defn take
  [n sequence]
  (if (vector? sequence)
    (take-vector n sequence)
    (take-list n sequence)))

(defn variadic?
  "Returns true if function signature is variadic"
  [params]
  (>= (.index-of params '&) 0))

(defn overload-arity
  "Returns aritiy of the expected arguments for the
  overleads signature"
  [params]
  (if (variadic?)
    (.index-of params '&)
    (.-length params)))

(defn analyze-overloaded-fn
  "Compiles function that has overloads defined"
  [name doc attrs overloads]
  (map (fn [overload]
         (let [params (first overload)
               variadic (variadic? params)
               fixed-arity (if variadic
                              (- (count params) 2)
                              (count params))]
           {:variadic variadic
            :rest (if variadic? (get params (dec (count params))) nil)
            :fixed-arity fixed-arity
            :params (take fixed-arity params)
            :body (rest overload)}))
       overloads))

(defn compile-overloaded-fn
  [name doc attrs overloads]
  (let [methods (analyze-overloaded-fn name doc attrs overloads)
        fixed-methods (filter (fn [method] (not (:variadic method))) methods)
        variadic (first (filter (fn [method] (:variadic method)) methods))
        names (reduce-list methods
                           (fn [a b]
                            (if (> (count a) (count (get b :params)))
                              a
                              (get b :params))) [])]
    (list 'fn name doc attrs names
          (list 'raw*
                (compile-switch
                  'arguments.length
                  (map (fn [method]
                    (cons (:fixed-arity method)
                          (list 'raw*
                                (compile-fn-body
                                  (concat-list
                                    (compile-rebind names (:params method))
                                    (:body method))))))
                    fixed-methods)
                  (if (nil? variadic)
                    '(throw (Error "Invalid arity"))
                    (list 'raw*
                          (compile-fn-body
                            (concat-list
                              (compile-rebind
                                (cons `(Array.prototype.slice.call
                                        arguments
                                        ~(:fixed-arity variadic))
                                      names)
                                (cons (:rest variadic)
                                      (:params variadic)))
                              (:body variadic)))))))
          nil)))

(defn compile-rebind
  "Takes vector of bindings and a vector of names this binding needs to
  get bound to and returns list of def expressions that bind bindings to
  a new names. If names matches associated binding it will be ignored."
  [bindings names]
  ;; Loop through the given names and bindings and assembling a `form`
  ;; list containing set expressions.
  (loop [form '()
         bindings bindings
         names names]
    ;; If all the names have bing iterated return reversed form. Form is
    ;; reversed since later bindings will be cons-ed later, appearing in
    ;; inverse order.
    (if (empty? names)
      (reverse form)
      (recur
       ;; If name and binding are identical then rebind is unnecessary
       ;; and it's skipped. Also not skipping such rebinds could be
       ;; problematic as definitions may shadow bindings.
       (if (identical? (first names) (first bindings))
         form
         (cons (list 'def (first names) (first bindings)) form))
       (rest bindings)
       (rest names)))))

(defn compile-switch-cases
  [cases]
  (reduce-list
   cases
   (fn [form case-expression]
     (str form
          (compile-template
           (list "case ~{}:\n  ~{}\n"
                 (compile (macroexpand (first case-expression)))
                 (compile (macroexpand (rest case-expression)))))))
   ""))

(defn compile-switch
  [value cases default-case]
  (compile-template
   (list "switch (~{}) {\n  ~{}\n  default:\n    ~{}\n}"
         (compile (macroexpand value))
         (compile-switch-cases cases)
         (compile (macroexpand default-case)))))

(install-macro
  'fn*
  (fn
  "Defines function form"
  [name doc attrs & body]
  ;; If second argument is a vector than function does not defiens
  ;; any overloads so we just create reguralr `fn`.
  (if (vector? (first body))
    `(fn ~name ~doc ~attrs ~@body)
    ;; Otherwise we iterate over each overlead forming a relevant
    ;; conditions.
    (compile-overloaded-fn name doc attrs body))))

(export
  self-evaluating?
  compile
  compile-program
  macroexpand
  macroexpand-1)

(import [read-from-string] "./reader")
(import [meta with-meta symbol? symbol keyword? keyword
         unquote? unquote-splicing? quote? syntax-quote? name gensym] "./ast")
(import [empty? count list? list first second third rest cons
         reverse map-list concat-list reduce-list list-to-vector] "./list")
(import [odd? dictionary? dictionary merge keys vals contains-vector?
         map-dictionary string? number? vector? boolean?
         true? false? nil? re-pattern? inc dec str] "./runtime")

(defn ^boolean self-evaluating?
  "Returns true if form is self evaluating"
  [form]
  (or (number? form)
      (and (string? form)
           (not (symbol? form))
           (not (keyword? form)))
      (boolean? form)
      (nil? form)
      (re-pattern? form)))

;; Macros

(def __macros__ {})

(defn execute-macro
  "Applies macro registered with given `name` to a given `form`"
  [name form]
  (apply (get __macros__ name)
         (list-to-vector form)))

(defn install-macro
  "Registers given `macro` with a given `name`"
  [name macro-fn]
  (set! (get __macros__ name) macro-fn))

(defn macro?
  "Returns true if macro with a given name is registered"
  [name]
  (and (symbol? name)
       (get __macros__ name)
       true))

(defn make-macro
  "Makes macro"
  [pattern body]
  (let [macro-fn `(fn ~pattern ~@body)]
        ;; compile the macro into native code and use the host's native
        ;; eval to eval it into a function.
        (eval (str "(" (compile (macroexpand macro-fn)) ")"))))

(install-macro
 'defmacro
 (fn
  "Like defn, but the resulting function name is declared as a
  macro and will be used as a macro by the compiler when it is
  called."
  [name signature & body]
  (install-macro name (make-macro signature body))))

;; special forms
;;
;; special forms are like macros for generating source code. It allows the
;; generator to customize how certain forms look in the final output.
;; these could have been macros that expand into basic forms, but we
;; want readable output. Special forms are responsible for integrity
;; checking of the form.

(def __specials__ {})

(defn install-special
  "Installs special function"
  [name f validator]
  (set! (get __specials__ name)
        (fn [form]
          (if validator (validator form))
          (f (rest form)))))

(defn special?
  "Returns true if special form"
  [name]
  (and (symbol? name)
       (get __specials__ name)
       true))

(defn execute-special
  "Expands special form"
  [name form]
  ((get __specials__ name) form))

(defn opt [argument fallback]
  (if (or (nil? argument) (empty? argument)) fallback (first argument)))

(defn apply-form
  "Take a form that has a list of children and make a form that
  applies the children to the function `fn-name`"
  [fn-name form quoted?]
  (cons fn-name
        (if quoted?
            (map-list form (fn [e] (list 'quote e))) form)
            form))

(defn apply-unquoted-form
  "Same as apply-form, but respect unquoting"
  [fn-name form]
  (cons fn-name ;; ast.prepend ???
        (map-list
          form
          (fn [e]
              (if (unquote? e)
                  (second e)
                  (if (and (list? e)
                           (keyword? (first e)))
                      (list 'syntax-quote (second e))
                      (list 'syntax-quote e)))))))

(defn split-splices
  ""
  [form fn-name]

  (defn make-splice
    ""
    [form]
    (if (or (self-evaluating? form)
            (symbol? form))
        (apply-unquoted-form fn-name (list form))
        (apply-unquoted-form fn-name form)))

  (loop [nodes form
         slices '()
         acc '()]
   (if (empty? nodes)
       (reverse
        (if (empty? acc)
            slices
            (cons (make-splice (reverse acc)) slices)))
       (let [node (first nodes)]
        (if (unquote-splicing? node)
            (recur (rest nodes)
                   (cons (second node)
                         (if (empty? acc)
                             slices
                             (cons (make-splice (reverse acc)) slices)))
                   '())
            (recur (rest nodes)
                   slices
                   (cons node acc)))))))

(defn syntax-quote-split
  [append-name fn-name form]
  (let [slices (split-splices form fn-name)]
    (if (= (count slices) 1)
      (first slices)
      (apply-form append-name slices))))

;; compiler

(defn compile-object
  ""
  [form quoted?]
  ;; TODO: Add regexp to the list.
  (cond
    (keyword? form) (compile-keyword form)
    (symbol? form) (compile-symbol form)
    (number? form) (compile-number form)
    (string? form) (compile-string form)
    (boolean? form) (compile-boolean form)
    (nil? form) (compile-nil form)
    (re-pattern? form) (compile-re-pattern form)
    (vector? form) (compile (apply-form 'vector
                                        (apply list form)
                                        quoted?))
    (list? form) (compile (apply-form 'list
                                      form
                                      quoted?))
    (dictionary? form) (compile-dictionary
                        (if quoted?
                          (map-dictionary form (fn [x] (list 'quote x)))
                          form))))

(defn compile-reference
  "Translates references from clojure convention to JS:

  **macros**      __macros__
  list->vector    listToVector
  set!            set
  foo_bar         foo_bar
  number?         isNumber
  create-server   createServer"
  [form]
  (def id (name form))
  ;; **macros** ->  __macros__
  (set! id (.join (.split id "*") "_"))
  ;; list->vector ->  listToVector
  (set! id (.join (.split id "->") "-to-"))
  ;; set! ->  set
  (set! id (.join (.split id "!") ""))
  (set! id (.join (.split id "%") "$"))
  ;; number? -> isNumber
  (set! id (if (identical? (.substr id -1) "?")
             (str "is-" (.substr id 0 (- (.-length id) 1)))
             id))
  ;; create-server -> createServer
  (set! id (.reduce
            (.split id "-")
            (fn [result key]
              (str result
                   (if (and (not (empty? result))
                            (not (empty? key)))
                     (str (.to-upper-case (get key 0)) (.substr key 1))
                     key)))
            ""))
  id)

(defn compile-keyword-reference
  [form]
  (str "\"" (name form) "\""))

(defn compile-syntax-quoted
  ""
  [form]
  (cond
   (list? form) (compile (syntax-quote-split 'concat-list 'list form))
   (vector? form)
    (compile (syntax-quote-split 'concat-vector 'vector (apply list form)))
   (dictionary? form) (compile (syntax-quote-split 'merge 'dictionary form))
   :else (compile-object form)))

(defn compile
  "compiles given form"
  [form]
  (cond
   (self-evaluating? form) (compile-object form)
   (symbol? form) (compile-reference form)
   (keyword? form) (compile-keyword-reference form)
   (vector? form) (compile-object form)
   (dictionary? form) (compile-object form)
   (list? form)
    (let [head (first form)]
      (cond
       (quote? form) (compile-object (second form) true)
       (syntax-quote? form) (compile-syntax-quoted (second form))
       (special? head) (execute-special head form)
       ;; Compile keyword invoke as a property access.
       (keyword? head) (compile (list 'get (second form) head))
       :else (do
              (if (not (or (symbol? head) (list? head)))
                (throw (compiler-error
                        form
                        (str "operator is not a procedure: " head)))
              (compile-invoke form)))))))

(defn compile-program
  "compiles all expansions"
  [forms]
  (loop [result ""
         expressions forms]
    (if (empty? expressions)
      result
      (recur
        (str result
             (if (empty? result) "" ";\n\n")
             (compile (macroexpand (first expressions))))
        (rest expressions)))))

(defn macroexpand-1
  "If form represents a macro form, returns its expansion,
  else returns form."
  [form]
  (if (list? form)
    (let [op (first form)
          id (name op)]
      (cond
        (special? op) form
        (macro? op) (execute-macro op (rest form))
        (and (symbol? op)
             (not (identical? id ".")))
          ;; (.substring s 2 5) => (. s substring 2 5)
          (if (identical? (.char-at id 0) ".")
            (if (< (count form) 2)
              (throw (Error
                "Malformed member expression, expecting (.member target ...)"))
              (cons '.
                    (cons (second form)
                          (cons (symbol (.substr id 1))
                                (rest (rest form))))))

            ;; (StringBuilder. "foo") => (new StringBuilder "foo")
            (if (identical? (.char-at id (- (.-length id) 1)) ".")
              (cons 'new
                    (cons (symbol (.substr id 0 (- (.-length id) 1)))
                          (rest form)))
              form))
        :else form))
      form))

(defn macroexpand
  "Repeatedly calls macroexpand-1 on form until it no longer
  represents a macro form, then returns it."
  [form]
  (loop [original form
         expanded (macroexpand-1 form)]
    (if (identical? original expanded)
      original
      (recur expanded (macroexpand-1 expanded)))))

;; backend specific compiler hooks

(defn compile-template
  "Compiles given template"
  [form]
  (def indent-pattern #"\n *$")
  (def line-break-patter (RegExp "\n" "g"))
  (defn get-indentation [code]
    (let [match (.match code indent-pattern)]
      (or (and match (get match 0)) "\n")))

  (loop [code ""
         parts (.split (first form) "~{}")
         values (rest form)]
    (if (> (.-length parts) 1)
      (recur
       (str
        code
        (get parts 0)
        (.replace (str "" (first values))
                  line-break-patter
                  (get-indentation (get parts 0))))
       (.slice parts 1)
       (rest values))
       (.concat code (get parts 0)))))

(defn compile-def
  "Creates and interns or locates a global var with the name of symbol
  and a namespace of the value of the current namespace (*ns*). If init
  is supplied, it is evaluated, and the root binding of the var is set
  to the resulting value. If init is not supplied, the root binding of
  the var is unaffected. def always applies to the root binding, even if
  the var is thread-bound at the point where def is called. def yields
  the var itself (not its value)."
  [form]
  (compile-template
   (list "var ~{}"
         (compile (cons 'set! form)))))

(defn compile-if-else
  "Evaluates test. If not the singular values nil or false,
  evaluates and yields then, otherwise, evaluates and yields else.
  If else is not supplied it defaults to nil. All of the other
  conditionals in Clojure are based upon the same logic, that is,
  nil and false constitute logical falsity, and everything else
  constitutes logical truth, and those meanings apply throughout."
  [form]
  (let [condition (macroexpand (first form))
        then-expression (macroexpand (second form))
        else-expression (macroexpand (third form))]
    (compile-template
      (list
        (if (and (list? else-expression)
                 (identical? (first else-expression) 'if))
          "~{} ?\n  ~{} :\n~{}"
          "~{} ?\n  ~{} :\n  ~{}")
        (compile condition)
        (compile then-expression)
        (compile else-expression)))))

(defn compile-dictionary
  "Compiles dictionary to JS object"
  [form]
  (let [body
        (loop [body nil
               names (keys form)]
          (if (empty? names)
            body
            (recur
             (str
              (if (nil? body) "" (str body ",\n"))
              (compile-template
               (list
                "~{}: ~{}"
                (compile (first names))
                (compile (macroexpand
                          (get form (first names)))))))
             (rest names))))
        ]
      (if (nil? body) "{}" (compile-template (list "{\n  ~{}\n}" body)))))

(defn desugar-fn-name [form]
  (if (symbol? (first form)) form (cons nil form)))

(defn desugar-fn-doc [form]
  (if (string? (second form))
    form
    (cons (first form) ;; (name nil ... )
          (cons nil (rest form)))))

(defn desugar-fn-attrs [form]
  (if (dictionary? (third form))
    form
    (cons (first form) ;; (name nil ... )
          (cons (second form)
            (cons nil (rest (rest form)))))))

(defn desugar-body [form]
  (if (list? (third form))
    form
    (with-meta
     (cons (first form)
           (cons (second form)
                 (list (rest (rest form)))))
     (meta (third form)))))

(defn compile-fn-params
  ;"compiles function params"
  [params]
  (if (contains-vector? params '&)
    (.join (.map (.slice params 0 (.index-of params '&)) compile) ", ")
    (.join (.map params compile) ", ")))

(defn compile-desugared-fn
  ;"(fn name? [params* ] exprs*)

  ;Defines a function (fn)"
  [name doc attrs params body]
  (compile-template
    (if (nil? name)
      (list "function(~{}) {\n  ~{}\n}"
            (compile-fn-params params)
            (compile-fn-body body params))
      (list "function ~{}(~{}) {\n  ~{}\n}"
            (compile name)
            (compile-fn-params params)
            (compile-fn-body body params)))))

(defn compile-statements
  [form prefix]
  (loop [result ""
         expression (first form)
         expressions (rest form)]
    (if (empty? expressions)
      (str result
           (if (nil? prefix) "" prefix)
           (compile (macroexpand expression))
           ";")
      (recur
        (str result (compile (macroexpand expression)) ";\n")
        (first expressions)
        (rest expressions)))))

(defn compile-fn-body
  [form params]
  (if (and (vector? params) (contains-vector? params '&))
    (compile-statements
      (cons (list 'def
                  (get params (inc (.index-of params '&)))
                  (list
                    'Array.prototype.slice.call
                    'arguments
                    (.index-of params '&)))
      form)
      "return ")
    (compile-statements form "return ")))

(defn compile-fn
  "(fn name? [params* ] exprs*)

  Defines a function (fn)"
  [form]
  (let [signature (desugar-fn-attrs (desugar-fn-doc (desugar-fn-name form)))
        name (first signature)
        doc (second signature)
        attrs (third signature)
        params (third (rest signature))
        body (rest (rest (rest (rest signature))))]
    (compile-desugared-fn name doc attrs params body)))

(defn compile-invoke
  [form]
  (compile-template
   ;; Wrap functions returned by expressions into parenthesis.
   (list (if (list? (first form)) "(~{})(~{})" "~{}(~{})")
         (compile (first form))
         (compile-group (rest form)))))

(defn compile-group
  [form wrap]
  (if wrap
    (str "(" (compile-group form) ")")
    (.join (list-to-vector
            (map-list (map-list form macroexpand) compile)) ", ")))

(defn compile-do
  "Evaluates the expressions in order and returns the value of the last.
  If no expressions are supplied, returns nil."
  [form]
  (compile (list (cons 'fn (cons [] form)))))

(defn define-bindings
  "Returns list of binding definitions"
  [form]
  (loop [defs '()
         bindings form]
    (if (= (count bindings) 0)
      (reverse defs)
      (recur
        (cons
          (list 'def                ; '(def (get bindings 0) (get bindings 1))
                (get bindings 0)    ; binding name
                (get bindings 1))   ; binding value
           defs)
        (rest (rest bindings))))))

(defn compile-let
  "Evaluates the exprs in a lexical context in which the symbols in
  the binding-forms are bound to their respective init-exprs or parts
  therein."
  ; {:added "1.0", :special-form true, :forms '[(let [bindings*] exprs*)]}
  [form]
  ;; TODO: Implement destructure for bindings:
  ;; https://github.com/clojure/clojure/blob/master/src/clj/clojure/core.clj#L3937
  ;; Consider making let a macro:
  ;; https://github.com/clojure/clojure/blob/master/src/clj/clojure/core.clj#L3999
  (compile
    (cons 'do
          (concat-list
            (define-bindings (first form))
            (rest form)))))

(defn compile-throw
  "The expression is evaluated and thrown, therefore it should yield an error."
  [form]
  (compile-template
    (list "(function() { throw ~{}; })()"
          (compile (macroexpand (first form))))))

(defn compile-set
  "Assignment special form.

  When the first operand is a field member access form, the assignment
  is to the corresponding field."
  ; {:added "1.0", :special-form true, :forms '[(loop [bindings*] exprs*)]}
  [form]
  (compile-template
    (list "~{} = ~{}"
      (compile (macroexpand (first form)))
      (compile (macroexpand (second form))))))

(defn compile-vector
  "Creates a new vector containing the args"
  [form]
  (compile-template (list "[~{}]" (compile-group form))))

(defn compile-try
  "The exprs are evaluated and, if no exceptions occur, the value
  of the last is returned. If an exception occurs and catch clauses
  are provided, its exprs are evaluated in a context in which name is
  bound to the thrown exception, and the value of the last is the return
  value of the function. If there is no matching catch clause, the exception
  propagates out of the function. Before returning, normally or abnormally,
  any finally exprs will be evaluated for their side effects."
  [form]
  (loop [try-exprs '()
         catch-exprs '()
         finally-exprs '()
         exprs (reverse form)]
    (if (empty? exprs)
      (if (empty? catch-exprs)
        (compile-template
          (list
            "(function() {\ntry {\n  ~{}\n} finally {\n  ~{}\n}})()"
            (compile-fn-body try-exprs)
            (compile-fn-body finally-exprs)))
        (if (empty? finally-exprs)
          (compile-template
            (list
              "(function() {\ntry {\n  ~{}\n} catch (~{}) {\n  ~{}\n}})()"
              (compile-fn-body try-exprs)
              (compile (first catch-exprs))
              (compile-fn-body (rest catch-exprs))))
          (compile-template
            (list
              "(function() {\ntry {\n  ~{}\n} catch (~{}) {\n  ~{}\n} finally {\n  ~{}\n}})()"
              (compile-fn-body try-exprs)
              (compile (first catch-exprs))
              (compile-fn-body (rest catch-exprs))
              (compile-fn-body finally-exprs)))))
        (if (identical? (first (first exprs)) 'catch)
          (recur try-exprs
                 (rest (first exprs))
                 finally-exprs
                 (rest exprs))
          (if (identical? (first (first exprs)) 'finally)
            (recur try-exprs
                   catch-exprs
                   (rest (first exprs))
                   (rest exprs))
            (recur (cons (first exprs) try-exprs)
                   catch-exprs
                   finally-exprs
                   (rest exprs)))))))

(defn compile-property
  "(. object method arg1 arg2)

  The '.' special form that can be considered to be a method call,
  operator"
  [form]
  ;; (. object method arg1 arg2) -> (object.method arg1 arg2)
  ;; (. object -property) -> object.property
  (if (identical? (aget (name (second form)) 0) "-")
    (compile-template
      (list (if (list? (first form)) "(~{}).~{}" "~{}.~{}")
            (compile (macroexpand (first form)))
            (compile (macroexpand (symbol (.substr (name (second form)) 1))))))
    (compile-template
      (list "~{}.~{}(~{})"
            (compile (macroexpand (first form)))    ;; object name
            (compile (macroexpand (second form)))   ;; method name
            (compile-group (rest (rest form)))))))  ;; args

(defn compile-apply
  [form]
  (compile
    (list '.
          (first form)
          'apply
          (first form)
          (second form))))

(defn compile-new
  "(new Classname args*)
  Compiles new special form. The args, if any, are evaluated
  from left to right, and passed to the constructor of the
  class named by Classname. The constructed object is returned."
  ; {:added "1.0", :special-form true, :forms '[(new Classname args*)]}
  [form]
  (compile-template (list "new ~{}" (compile form))))

(defn compile-compound-accessor
  "Compiles compound property accessor"
  [form]
  (compile-template
    (list "~{}[~{}]"
          (compile (macroexpand (first form)))
          (compile (macroexpand (second form))))))

(defn compile-instance
  "Evaluates x and tests if it is an instance of the class
  c. Returns true or false"
  [form]
  (compile-template (list "~{} instanceof ~{}"
                          (compile (macroexpand (second form)))
                          (compile (macroexpand (first form))))))

(defn compile-not
  "Returns true if x is logical false, false otherwise."
  [form]
  (compile-template (list "!(~{})" (compile (macroexpand (first form))))))

(defn compile-loop
  "Evaluates the body in a lexical context in which the symbols
  in the binding-forms are bound to their respective
  initial-expressions or parts therein. Acts as a recur target."
  [form]
  (let [bindings (apply dictionary (first form))
        names (keys bindings)
        values (vals bindings)
        body (rest form)]
    ;; `((fn loop []
    ;;    ~@(define-bindings bindings)
    ;;    ~@(compile-recur body names)))
    (compile
      (cons (cons 'fn
              (cons 'loop
                (cons names
                  (compile-recur names body))))
            (apply list values)))))

(defn rebind-bindings
  "Rebinds given bindings to a given names in a form of
  (set! foo bar) expressions"
  [names values]
  (loop [result '()
         names names
         values values]
    (if (empty? names)
      (reverse result)
      (recur
       (cons (list 'set! (first names) (first values)) result)
       (rest names)
       (rest values)))))

(defn expand-recur
  "Expands recur special form into params rebinding"
  [names body]
  (map-list body
       (fn [form]
         (if (list? form)
           (if (identical? (first form) 'recur)
             (list 'raw*
                   (compile-group
                    (concat-list
                      (rebind-bindings names (rest form))
                      (list 'loop))
                    true))
             (expand-recur names form))
           form))))

(defn compile-recur
  "Eliminates tail calls in form of recur and rebinds the bindings
  of the recursion point to the parameters of the recur"
  [names body]
  (list
    (list 'raw*
          (compile-template
          (list "var recur = loop;\nwhile (recur === loop) {\n  recur = ~{}\n}"
                (compile-statements (expand-recur names body)))))
    'recur))

(defn compile-raw
  "returns form back since it's already compiled"
  [form]
  (first form))

(install-special 'set! compile-set)
(install-special 'get compile-compound-accessor)
(install-special 'aget compile-compound-accessor)
(install-special 'def compile-def)
(install-special 'if compile-if-else)
(install-special 'do compile-do)
(install-special 'do* compile-statements)
(install-special 'fn compile-fn)
(install-special 'let compile-let)
(install-special 'throw compile-throw)
(install-special 'vector compile-vector)
(install-special 'try compile-try)
(install-special '. compile-property)
(install-special 'apply compile-apply)
(install-special 'new compile-new)
(install-special 'instance? compile-instance)
(install-special 'not compile-not)
(install-special 'loop compile-loop)
(install-special 'raw* compile-raw)

(defn compile-keyword [form] (str "\"" "\uA789" (name form) "\""))
(defn compile-symbol [form] (str "\"" "\uFEFF" (name form) "\""))
(defn compile-nil [form] "void(0)")
(defn compile-number [form] form)
(defn compile-boolean [form] (if (true? form) "true" "false"))
(defn compile-string
  [form]
  (set! form (.replace form (RegExp "\\\\" "g") "\\\\"))
  (set! form (.replace form (RegExp "\n" "g") "\\n"))
  (set! form (.replace form (RegExp "\r" "g") "\\r"))
  (set! form (.replace form (RegExp "\t" "g") "\\t"))
  (set! form (.replace form (RegExp "\"" "g") "\\\""))
  (str "\"" form "\""))

(defn compile-re-pattern
  [form]
  (str form))

(defn install-native
  "Creates an adapter for native operator"
  [alias operator validator fallback]
  (install-special
   alias
   (fn [form]
    (reduce-list
      (map-list form
                (fn [operand]
                  (compile-template
                    (list (if (list? operand) "(~{})" "~{}")
                      (compile (macroexpand operand))))))
      (fn [left right]
        (compile-template
          (list "~{} ~{} ~{}"
                left
                (name operator)
                right)))
      (if (empty? form) fallback nil)))
    validator))

(defn install-operator
  "Creates an adapter for native operator that does comparison in
  monotonical order"
  [alias operator]
  (install-special
   alias
   (fn [form]
    (loop [result ""
           left (first form)
           right (second form)
           operands (rest (rest form))]
      (if (empty? operands)
        (str result
             (compile-template (list "~{} ~{} ~{}"
                                     (compile (macroexpand left))
                                     (name operator)
                                     (compile (macroexpand right)))))
        (recur
          (str result
              (compile-template (list "~{} ~{} ~{} && "
                                      (compile (macroexpand left))
                                      (name operator)
                                      (compile (macroexpand right)))))
          right
          (first operands)
          (rest operands)))))
   verify-two))

(defn compiler-error
  [form message]
  (let [error (Error (str message))]
    (set! error.line 1)
    (throw error)))

(defn verify-two
  [form]
  (if (or (empty? (rest form))
          (empty? (rest (rest form))))
    (throw
      (compiler-error
        form
        (str (first form) " form requires at least two operands")))))

;; Arithmetic Operators
(install-native '+ '+ nil 0)
(install-native '- '- nil "NaN")
(install-native '* '* nil 1)
(install-native '/ '/ verify-two)
(install-native 'mod (symbol "%") verify-two)

;; Logical Operators
(install-native 'and '&&)
(install-native 'or '||)

;; Comparison Operators

(install-operator '= '==)
(install-operator 'not= '!=)
(install-operator '== '==)
(install-operator 'identical? '===)
(install-operator '> '>)
(install-operator '>= '>=)
(install-operator '< '<)
(install-operator '<= '<=)

;; Bitwise Operators

(install-native 'bit-and '& verify-two)
(install-native 'bit-or '| verify-two)
(install-native 'bit-xor (symbol "^"))
(install-native 'bit-not (symbol "~") verify-two)
(install-native 'bit-shift-left '<< verify-two)
(install-native 'bit-shift-right '>> verify-two)
(install-native 'bit-shift-right-zero-fil '>>> verify-two)

(install-macro
 'cond
 (fn cond
   "Takes a set of test/expr pairs. It evaluates each test one at a
   time.  If a test returns logical true, cond evaluates and returns
   the value of the corresponding expr and doesn't evaluate any of the
   other tests or exprs. (cond) returns nil."
   {:added "1.0"}
   [& clauses]
   (if (not (empty? clauses))
     (list 'if (first clauses)
           (if (empty? (rest clauses))
             (throw (Error "cond requires an even number of forms"))
             (second clauses))
           (cons 'cond (rest (rest clauses)))))))

(install-macro
 'defn
 (fn defn
   "Same as (def name (fn [params* ] exprs*)) or
   (def name (fn ([params* ] exprs*)+)) with any doc-string or attrs added
   to the var metadata"
   {:added "1.0" :special-form true }
   [name & body]
   `(def ~name (fn ~name ~@body))))

(install-macro
 'assert
 (fn assert
   "Evaluates expr and throws an exception if it does not evaluate to
   logical true."
   {:added "1.0"}
   [x message]
   (if (nil? message)
     `(assert ~x "")
     `(if (not ~x)
        (throw (Error. (.concat "Assert failed: " ~message "\n" '~x)))))))

(install-macro
 'export
 (fn
   "Helper macro for exporting multiple / single value"
   [& names]
   (if (empty? names)
     nil
     (if (empty? (rest names))
       `(set! module.exports ~(first names))
       (loop [form '() exports names]
         (if (empty? exports)
           `(do* ~@form)
           (recur (cons `(set!
                          (~(symbol (str ".-" (name (first exports))))
                            exports)
                          ~(first exports))
                        form)
                  (rest exports))))))))

(install-macro
 'import
 (fn
   "Helper macro for importing node modules"
   [imports path]
   (if (nil? path)
     `(require ~imports)
     (if (symbol? imports)
       `(def ~imports (require ~path))
       (loop [form '() names imports]
         (if (empty? names)
           `(do* ~@form)
           (let [alias (first names)
                 id (symbol (str ".-" (name alias)))]
             (recur (cons `(def ~alias
                             (~id (require ~path))) form)
                    (rest names)))))))))
;; TODO:
;; - alength
;; - defn with metadata in front of name
;; - declare

(export
  self-evaluating?
  compile
  compile-program
  macroexpand
  macroexpand-1)


Fix Fibonacci definition.

Fix Fibonacci definition.

;;; Small example wisp functions

(defun fib (n)
  (if (<= n 2) 1
    (+ (fib (- n 1)) (fib (- n 2)))))

;;; Small example wisp functions

(defun fib (n)
  (if (>= n 2) 1
    (+ (fib (- n 1)) (fib (- n 2)))))


fix(promise): bad namespace

fix(promise): bad namespace

(ns promitto.lib.promise
  (:require
    [promitto.lib.utils :refer [chain]]
    [promitto.lib.types :refer [states]]))

(defn ^:private then-fn
  [push dispatch]
  (fn [resolve reject notify]
    (def args arguments)
    (.for-each states (fn [name index]
      (push name (aget args index))))
    (.for-each states dispatch)))

(defn ^:private finally-fn
  [push dispatch]
  (fn [callback]
    (push :finally callback)
    (dispatch :finally)))

(defn ^:private catch-fn
  [push dispatch]
  (fn [callback]
    (push :reject callback)
    (dispatch :reject)))

(defn ^:private notify-fn
  [state push dispatch]
  (fn [callback]
    (push :notify callback)
    (dispatch :notify)))

(defn ^:private Promise
  [ctx]
  (fn Promise [resolve reject notify]
    (.apply (.-then ctx) ctx arguments) ctx))

(defn ^:private new-promise
  [ctx]
  (let [Promise (Promise ctx)]
    (.for-each (.keys Object ctx)
      (fn [name]
        (set! (aget Promise name)
          (chain Promise
            (aget ctx name))))) Promise))

(defn ^object promise
  "Create a new Promise"
  [state push dispatch]
  (def ctx
    { :then (then-fn push dispatch)
      :finally (finally-fn push dispatch)
      :catch (catch-fn push dispatch)
      :notify (notify-fn state push dispatch) }) (new-promise ctx))

(ns promitto.lib.
  (:require
    [promitto.lib.utils :refer [chain]]
    [promitto.lib.types :refer [states]]))

(defn ^:private then-fn
  [push dispatch]
  (fn [resolve reject notify]
    (def args arguments)
    (.for-each states (fn [name index]
      (push name (aget args index))))
    (.for-each states dispatch)))

(defn ^:private finally-fn
  [push dispatch]
  (fn [callback]
    (push :finally callback)
    (dispatch :finally)))

(defn ^:private catch-fn
  [push dispatch]
  (fn [callback]
    (push :reject callback)
    (dispatch :reject)))

(defn ^:private notify-fn
  [state push dispatch]
  (fn [callback]
    (push :notify callback)
    (dispatch :notify)))

(defn ^:private Promise
  [ctx]
  (fn Promise [resolve reject notify]
    (.apply (.-then ctx) ctx arguments) ctx))

(defn ^:private new-promise
  [ctx]
  (let [Promise (Promise ctx)]
    (.for-each (.keys Object ctx)
      (fn [name]
        (set! (aget Promise name)
          (chain Promise
            (aget ctx name))))) Promise))

(defn ^object promise
  "Create a new Promise"
  [state push dispatch]
  (def ctx
    { :then (then-fn push dispatch)
      :finally (finally-fn push dispatch)
      :catch (catch-fn push dispatch)
      :notify (notify-fn state push dispatch) }) (new-promise ctx))