(set sibilant 'tokens {})

(set sibilant.tokens
     'regex              "(\\/(\\\\\\\/|[^\\/\\n])+\\/[glim]*)"
     'comment            "(;.*)"
     'string             "(\"(([^\"]|(\\\\\"))*[^\\\\])?\")"
     'number             "(-?[0-9][0-9.,]*)"
     'literal            "(-?[*.$a-zA-Z][*.a-zA-Z0-9-]*(\\?|!)?)"
     'special            "([&']?)"
     'other-char         "([><=!\\+\\/\\*-]+)"
     'open-paren         "(\\()"
     'special-open-paren "('?\\()"
     'close-paren        "(\\))"
     'alternative-parens "\\{|\\[|\\}|\\]"
     'special-literal    (concat sibilant.tokens.special
                                 sibilant.tokens.literal))

(set sibilant 'token-precedence
     '( regex comment string number special-literal other-char
              special-open-paren close-paren alternative-parens))

(defvar tokenize
        (setf sibilant.tokenize
              (lambda (string)
                (defvar tokens []
                        parse-stack [tokens]
                        specials [])

                (defun accept-token (token)
                  (send (get parse-stack 0) push token))

                (defun increase-nesting ()
                  (defvar new-arr [])
                  (accept-token new-arr)
                  (parse-stack.unshift new-arr))

                (defun decrease-nesting ()
                  (specials.shift)
                  (parse-stack.shift)
                  (when (zero? parse-stack.length)
                    (throw (concat "unbalanced parens:\n"
                                   (call inspect parse-stack)))))

                (defun handle-token (token)
                  (defvar special (first token)
                          token token)

                  (if (= special "'")
                    (progn
                      (setf token (token.slice 1))
                      (increase-nesting)
                      (accept-token 'quote))
                    (setf special false))

                  (specials.unshift (as-boolean special))

                  (switch token
                    ("(" (increase-nesting))
                    (("]" "}" ")") (decrease-nesting))

                    ("{" (increase-nesting) (accept-token 'hash))
                    ("[" (increase-nesting) (accept-token 'list))

                    (default
                     (if (token.match (regex (concat "^" sibilant.tokens.number "$")))
                       (accept-token (parse-float (token.replace (regex "," 'g) "")))
                       (accept-token token))))

                  (when (and (!= token "(")
                             (specials.shift))
                    (decrease-nesting)))



                (defvar ordered-regexen (map sibilant.token-precedence
                                             (lambda (x) (get sibilant.tokens x)))
                        master-regex (regex (join "|" ordered-regexen) 'g))

                (chain string
                  (match master-regex)
                  (for-each handle-token))

                (when (> parse-stack.length 1)
                  (error "unexpected EOF, probably missing a )\n"
                         (call inspect (first parse-stack))))
                tokens)))

(defun indent (&rest args)
  (concat
   (chain (compact args)
     (join "\n")
     (replace /^/ "\n")
     (replace /\n/g "\n  "))
   "\n"))

(defun construct-hash (array-of-arrays)
  (inject {} array-of-arrays
          (lambda (object item)
            (set object (first item) (get object (second item)))
            object)))

(defvar macros (hash))
(set sibilant 'macros macros)

(set macros 'return
     (lambda (token)
       (defvar default-return (concat "return " (translate token)))

       (if (list? token)
         (switch (first token)
           ('(return throw progn) (translate token))
           ('delete
            (defvar delete-macro (get macros 'delete))
            (if (< token.length 3) default-return
                (concat (apply delete-macro (token.slice 1 -1))
                        "\nreturn "
                        (delete-macro (last token)))))
           ('setf
            (if (< token.length 4) default-return
                (concat (apply macros.setf
                               (token.slice 1 (- token.length 2)))
                        "\nreturn "
                        (apply macros.setf (token.slice -2)))))
           ('set
            (if (< token.length 5) default-return
                (progn
                  (defvar obj (second token)
                          non-return-part (token.slice 2 (- token.length 2))
                          return-part (token.slice -2))
                  (non-return-part.unshift obj)
                  (return-part.unshift obj)
                  (concat (apply macros.set non-return-part)
                          "\nreturn "
                          (apply macros.set return-part)))))
           (default default-return))
         default-return)))

(defun as-statement (string)
  (chain string (to-string) (replace /;*\s*$/ ";")))

(defun macros.statement (&rest args)
  (concat (apply macros.call args) ";\n"))

(defun macros.progn (&rest body)
  (defvar last-index (-math.max 0 (- body.length 1)))

  (set body last-index ['return (get body last-index)])

  (join "\n"
        (map body (lambda (arg)
                    (concat (as-statement (translate arg)))))))

(defun macros.empty-list () 'null)

(defun macros.call (fn-name &rest args)
  (concat (translate fn-name)
          "(" (join ", " (map args translate)) ")"))

(defun macros.defun (fn-name &rest args-and-body)
  (defvar fn-name-tr (translate fn-name)
          start (if (match? /\./ fn-name-tr) "" "var "))
  (concat start fn-name-tr " = "
          (apply macros.lambda args-and-body)
          ";\n"))

(defun macros.defmacro (name &rest args-and-body)
  (defvar js (apply macros.lambda args-and-body)
          name (translate name))
  (try (set macros name (eval js))
       (error (concat "error in parsing macro "
                      name ":\n" (indent js))))
  undefined)

(defun macros.concat (&rest args)
  (concat "(" (join " + " (map args translate)) ")"))

(defun transform-args (arglist)
  (defvar last undefined
          args [])
  (each (arg) arglist
    (if (= (first arg) "&") (setf last (arg.slice 1))
        (progn
          (args.push [ (or last 'required) arg ])
          (setf last null))))

  (when last
    (error (concat "unexpected argument modifier: " last)))

  args)


(defun macros.reverse (arr)
  (defvar reversed [])
  (each (item) arr (reversed.unshift item))
  reversed)

(defvar reverse macros.reverse)

(defun build-args-string (args rest)
  (defvar args-string ""
          optional-count 0)

  (each (arg option-index) args
    (when (= (first arg) 'optional)
      (setf
       args-string
       (concat
        args-string
        "if (arguments.length < "
        (- args.length optional-count) ")"
        (indent
         (concat "var "
                 (chain
                     (map (args.slice (+ option-index 1))
                          (lambda (arg arg-index)
                            (concat (translate (second arg)) " = "
                                    (translate (second (get args
                                                            (+ option-index
                                                               arg-index)))))))
                   (reverse)
                   (concat (concat (translate (second arg)) " = undefined"))
                   (join ", "))
                 ";"))))
      (incr optional-count)))

  (if (defined? rest)
    (concat args-string
            "var " (translate (second rest))
            " = Array.prototype.slice.call(arguments, "
            args.length ");\n")
    args-string))

(defun macros.lambda (arglist &rest body)
  (defvar args (transform-args arglist)
          rest (first (select args
                              (lambda (arg)
                                (= 'rest (first arg)))))
          doc-string undefined)

  (set body (- body.length 1)
       [ 'return (get body (- body.length 1)) ])

  (when (and (= (typeof (first body)) 'string)
             (send (first body) match /^".*"$/))
    (setf doc-string
          (concat "/* " (eval (body.shift)) " */\n")))

  (defvar no-rest-args (if rest (args.slice 0 -1) args)
          args-string (build-args-string no-rest-args rest))

  (concat "(function("
          (join ", " (map args (lambda (arg) (translate (second arg)))))
          ") {"
          (indent doc-string args-string
                  (join "\n"
                        (map body
                             (lambda (stmt)
                               (defvar tstmt (translate stmt))
                               (concat tstmt
                                 (if (= (last tstmt) ";") "" ";"))))))
          "})"))


(defun macros.quote (item)
  (if (= "Array" item.constructor.name)
    (concat "[ " (join ", " (map item macros.quote)) " ]")
    (if (= 'number (typeof item)) item
        (concat "\"" (literal item) "\""))))

(defun macros.hash (&rest pairs)
  (when (odd? pairs.length)
    (error (concat
            "odd number of key-value pairs in hash: "
            (call inspect pairs))))
  (defvar pair-strings
          (bulk-map pairs (lambda (key value)
                            (concat (translate key) ": "
                                    (translate value)))))
  (if (>= 1 pair-strings.length)
    (concat "{ " (join ", " pair-strings) " }")
    (concat "{" (indent (join ",\n" pair-strings)) "}")))


(defun literal (string)
  (inject (chain string
            (replace /\*/g "_")
            (replace /\?$/ "__QUERY")
            (replace /!$/  "__BANG"))
          (string.match /-(.)/g)
          (lambda (return-string match)
            (return-string.replace match
                                   (send (second match) to-upper-case)))))



(defun translate-list-token (token hint)
  (if (empty? token)
    (macros.empty-list)
    (if (defined? (get macros (translate (first token))))
      (apply (get macros (translate (first token))) (token.slice 1))
      (apply (get macros (or hint 'call)) token))))

(defun translate-string-token (token hint)
  (if (token.match (regex (concat "^" sibilant.tokens.literal "$")))
    (literal token)
    (if (token.match (regex "^;"))
      (token.replace (regex "^;+") "//")
      (if (= "\"" (first token) (last token))
        (chain token (split "\n") (join "\\n\" +\n\""))
        token))))

(defun translate (token hint)
  (defvar hint hint)
  (when (and hint (undefined? (get macros hint)))
    (setf hint undefined))

  (when (defined? token)
    (when (string? token) (setf token (token.trim)))
    (try
      (if (list? token)
        (translate-list-token token hint)
        (if (string? token)
          (translate-string-token token hint)
          token))
      (error (concat e.stack "\n"
                     "Encountered when attempting to process:\n"
                     (indent (call inspect token)))))))


(set sibilant 'translate translate)

(defun translate-all (contents)
  (defvar buffer "")
  (each (token) (tokenize contents)
    (defvar line (translate token 'statement))
    (when line (setf buffer (concat buffer line "\n"))))
  buffer)

(set sibilant 'translate-all translate-all)