;;;
;;; Copyright (c) 2010 Ivan Shvedunov. All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials
;;; provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(define-slime-contrib slime-js
  "Emacs-side support for Swank-JS."
  (:authors "Ivan Shvedunov")
  (:license "X11-style")
  (:on-load
   (add-hook 'slime-event-hooks 'slime-js-event-hook-function))
  (:on-unload
   (remove-hook 'slime-event-hooks 'slime-js-event-hook-function)))

(defun slime-js-repl-update-package ()
  (let ((name (slime-current-package)))
    (with-current-buffer (slime-output-buffer)
      (let ((previouse-point (- (point) slime-repl-input-start-mark)))
        (setf (slime-lisp-package) name
              (slime-lisp-package-prompt-string) name
              slime-buffer-package name)
        (slime-repl-insert-prompt)
        (when (plusp previouse-point)
          (goto-char (+ previouse-point slime-repl-input-start-mark)))))))

(defun slime-js-event-hook-function (event)
  (when (equal "JS" (slime-lisp-implementation-type))
    (destructure-case event
      ((:new-package package prompt)
       (let ((buffer (slime-connection-output-buffer)))
         (setf (slime-lisp-package) package)
         (setf (slime-lisp-package-prompt-string) prompt)
         (when (buffer-live-p buffer)
           (with-current-buffer buffer
             (setq slime-buffer-package package)
             (slime-js-repl-update-package)
             (save-excursion
               (goto-char (marker-position slime-repl-prompt-start-mark))
               (slime-mark-output-start))))
         t))
      (t nil))))

(defvar slime-js-remote-history nil
  "History list for JS remote names.")

(defun slime-js-read-remote-index (&optional prompt)
  (let* ((completion-ignore-case nil)
         (remotes (slime-eval '(js:list-remotes)))
         (remote-names
          (loop for remote in remotes
                collect (concat (third remote)
                                "/"
                                (replace-regexp-in-string
                                 "^:" ""(symbol-name (second remote))))))
         (prompt (or prompt "Remote: "))
         (p (or (position
                 (completing-read prompt (slime-bogus-completion-alist remote-names)
                                  nil nil nil
                                  'slime-remote-history nil)
                 remote-names :test #'equal)
                (error "bad remote name"))))
    (first (elt remotes p))))

(defun slime-js-select-remote (n)
  "Select JS remote by number"
  (interactive (list (slime-js-read-remote-index)))
  (slime-eval-async `(js:select-remote ,n nil)))

(defslime-repl-shortcut slime-repl-js-select-remote ("select-remote")
  (:handler 'slime-js-select-remote)
  (:one-liner "Select JS remote."))

(defun slime-js-sticky-select-remote (n)
  "Select JS remote by number in sticky mode"
  (interactive (list (slime-js-read-remote-index)))
  (slime-eval-async `(js:select-remote ,n t)))

(defslime-repl-shortcut slime-repl-js-sticky-select-remote ("sticky-select-remote")
  (:handler 'slime-js-sticky-select-remote)
  (:one-liner "Select JS remote in sticky mode."))

(defun slime-js-set-target-url (url)
  "Set target URL for the proxy"
  (interactive "sTarget URL: ")
  (slime-eval-async `(js:set-target-url ,url)))

(defslime-repl-shortcut slime-repl-js-set-target-url ("target-url")
  (:handler 'slime-js-set-target-url)
  (:one-liner "Select target URL for the swank-js proxy"))

(defun slime-js-set-slime-version (url)
  "Set SLIME version for swank-js"
  (interactive "sVersion: ")
  (slime-eval-async `(js:set-slime-version ,url)))

(defslime-repl-shortcut slime-repl-js-set-slime-version ("js-slime-version")
  (:handler 'slime-js-set-slime-version)
  (:one-liner "Set SLIME version for swank-js"))

;; FIXME: should add an rpc command for browser-only eval

(defun slime-js-eval (str &optional cont)
  (slime-eval-async `(swank:interactive-eval ,str) cont))

(defun slime-js-reload ()
  (interactive)
  (slime-js-eval "SwankJS.reload()"
    #'(lambda (v)
        (message "Reloading the page"))))

(defun slime-js-refresh-css ()
  (interactive)
  (slime-js-eval "SwankJS.refreshCSS()"
    #'(lambda (v)
        (message "Refreshing CSS"))))

(defun slime-js-start-of-toplevel-form ()
  (interactive)
  (when js2-mode-buffer-dirty-p
    (js2-mode-wait-for-parse #'slime-js-start-of-toplevel-form))
  (js2-forward-sws)
  (if (= (point) (point-max))
      (js2-mode-forward-sexp -1)
    (let ((node (js2-node-at-point)))
      (when (or (null node)
                (js2-ast-root-p node))
        (error "cannot locate any toplevel form"))
      (while (and (js2-node-parent node)
                  (not (js2-ast-root-p (js2-node-parent node))))
        (setf node (js2-node-parent node)))
      (goto-char (js2-node-abs-pos node))
      (js2-forward-sws)))
  (point))

(defun slime-js-end-of-toplevel-form ()
  (interactive)
  (js2-forward-sws)
  (let ((node (js2-node-at-point)))
    (unless (or (null node) (js2-ast-root-p node))
      (while (and (js2-node-parent node)
                  (not (js2-ast-root-p (js2-node-parent node))))
        (setf node (js2-node-parent node)))
      (goto-char (js2-node-abs-end node)))
    (point)))

;; FIXME: this breaks if // comment directly precedes the function
(defun slime-js-send-defun ()
  (interactive)
  (save-excursion
    (lexical-let ((start (slime-js-start-of-toplevel-form))
                  (end (slime-js-end-of-toplevel-form)))
      ;; FIXME: use slime-eval-region
      (slime-js-eval
       (buffer-substring-no-properties start end)
       #'(lambda (v)
           (save-excursion
             (goto-char start)
             (let ((sent-func "<...>"))
               (when (looking-at "[ \t]*\\([^ \t\n{}][^\n{}]*\\)")
                 (setf sent-func (match-string 1)))
               (message "Sent: %s" sent-func))))))))

(define-minor-mode slime-js-minor-mode
  "Toggle slime-js minor mode
With no argument, this command toggles the mode.
Non-null prefix argument turns on the mode.
Null prefix argument turns off the mode."
  nil
  " slime-js"
  '(("\C-\M-x"  . slime-js-send-defun)
    ("\C-c\C-c" . slime-js-send-defun)
    ;; ("\C-c\C-r" . slime-eval-region)
    ("\C-c\C-z" . slime-switch-to-output-buffer)))

;; TBD: dabbrev in repl:
;; DABBREV--GOTO-START-OF-ABBREV function skips over REPL prompt
;; because it has property 'intangible' and (forward-char -1) doesn't do
;; what is expected at the propmpt edge. Must redefine this function
;; or define and advice for it.
;; TBD: lost continuations (pipelined request ...) - maybe when closing page
(provide 'slime-js)