tern-project-dialog.el

tern-project-dialog.el

;;; tern-dialog.el --- 

;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
;; Version: 0.0.2
;; Package-Requires: ((tern "0.0.1") (widget-mvc "24"))

;;; Commentary:

;; M-x tern-prjfix-make
;; 

;;; Code:

(eval-when-compile (require 'cl))
(require 'json)
(require 'widget-mvc) ; https://github.com/kiwanami/emacs-widget-mvc


(defvar tern-home
  (let ((script-file (or load-file-name
                         (and (boundp 'bytecomp-filename) bytecomp-filename)
                         buffer-file-name)))
    (expand-file-name ".." (file-name-directory (file-truename script-file))))
  "installed tern-home.")

(eval-when-compile 
  (defmacro tern-prjfix-collect-gen (target)
    `(loop with plugins-dir = (expand-file-name ,target tern-home)
           for fn in (directory-files plugins-dir t "^[^\\.]")
           collect (list (gensym ,target) 
                         (file-name-sans-extension (file-name-nondirectory fn)) 
                         fn))))

(defun tern-prjfix-collect-libs ()
  (tern-prjfix-collect-gen "defs"))

(defun tern-prjfix-collect-plugins ()
  (tern-prjfix-collect-gen "plugin"))

(defun tern-prjfix-find-by-name (name item-list)
  "ITEM-LIST -> (list (sym pname content) ... )"
  (unless (stringp name)
    (setq name (format "%s" name)))
  (loop for item in item-list
        for pname = (cadr item)
        if (equal name pname) return item))

(defun tern-prjfix-collect-jsfiles (dir &optional base-dir)
  (unless base-dir
    (setq base-dir dir))
  (loop 
   with ret = nil
   for fn in (directory-files dir nil "^[^\\.]")
   for path = (expand-file-name fn dir)
   if (and (file-directory-p path) (not (string-match "node_modules" path)))
   do (setq ret (append (tern-prjfix-collect-jsfiles path base-dir) ret))
   else
   do (when (equal "js" (file-name-extension fn))
        (let ((name (file-relative-name path base-dir)))
          (setq ret (cons (list name name) ret))))
   finally return ret))

;;;###autoload
(defun tern-prjfix-make ()
  "Find a tern project file and show the editing dialog for the project file."
  (interactive)
  (let* ((pdir (tern-project-dir))
         (pfile (expand-file-name ".tern-project" pdir))
         project-data)
    (when (file-exists-p pfile)
      (setq project-data 
            (let ((json-array-type 'list))
              (ignore-errors
                (json-read-file pfile)))))
    (tern-prjfix-dialog-show pdir project-data)))

(defvar tern-prjfix-dialog-before-win-num 0  "[internal] ")

(defun tern-prjfix-dialog-show (pdir project-data)
  (let* ((libs (tern-prjfix-collect-libs))
         (plugins (tern-prjfix-collect-plugins))
         (jsfiles (tern-prjfix-collect-jsfiles pdir))
         (src `(
               ,(propertize "JavaScript Project Setting" 'face 'info-title-1) BR
               "Project Directory : " ,pdir BR BR
               ,(propertize "Project Environments" 'face 'info-title-2) BR
               ,@(loop for (sym name path) in libs
                       append (list `(input :name ,sym :type checkbox)
                                     "  " name 'BR))
               BR ,(propertize "Tern Plugins" 'face 'info-title-2) BR
               ,@(loop for (sym name path) in plugins
                       append (list `(input :name ,sym :type checkbox)
                                    "  " name 'BR))
               BR ,(propertize "Load Eagerly" 'face 'info-title-2) BR
               ,@(loop for (sym name path) in jsfiles
                       append (list `(input :name ,sym :type checkbox)
                                    "  " name 'BR))
               BR BR
               "  " (button :title "OK" :action on-submit :validation t)
               "  " (button :title "Cancel" :action on-cancel)))
        (model 
         (let ((data-plugins (cdr (assoc 'plugins project-data)))
               (data-libs (cdr (assoc 'libs project-data)))
               (data-jsfiles (cdr (assoc 'loadEagerly project-data))))
           (append
            (loop for (sym pname content) in plugins
                  for (name . opts) = (assoc (intern pname) data-plugins)
                  collect (cons sym (and name t)))
            (loop for (sym pname content) in libs
                  collect (cons sym (and (member pname data-libs) t)))
            (loop for (path name) in jsfiles
                  collect (cons path (and (member path data-jsfiles) t))))))
        (validations nil)
        (action-mapping 
         '((on-submit . tern-prjfix-submit-action)
           (on-cancel . tern-prjfix-dialog-kill-buffer)))
        (attributes (list 
                     (cons 'project-dir pdir) (cons 'libs libs)
                     (cons 'jsfiles jsfiles) (cons 'plugins plugins))))
    (setq tern-prjfix-dialog-before-win-num (length (window-list)))
    (pop-to-buffer
     (wmvc:build-buffer 
      :buffer (wmvc:get-new-buffer)
      :tmpl src :model model :actions action-mapping
      :validations validations :attributes attributes))))

(defun tern-prjfix-submit-action (model)
  (let* ((ctx wmvc:context)
         (pdir (wmvc:context-attr-get ctx 'project-dir))
         (pfile (expand-file-name ".tern-project" pdir))
         (plugins (wmvc:context-attr-get ctx 'plugins))
         (libs (wmvc:context-attr-get ctx 'libs))
         (jsfiles (wmvc:context-attr-get ctx 'jsfiles))
         (coding-system-for-write 'utf-8)
         (json-object-type 'hash-table)
         after-save-hook before-save-hook
         (json (json-encode 
                (list
                 (cons 'plugins
                       (loop with ps = (make-hash-table)
                             for (sym pname content) in plugins
                             for (msym . val) = (assoc sym model)
                             if val do
                             (puthash pname (make-hash-table) ps)
                             finally return ps))
                 (cons 'libs
                       (vconcat
                        (loop for (sym pname content) in libs
                              for (msym . val) = (assoc sym model)
                              if val collect pname)))
                 (cons 'loadEagerly
                       (vconcat
                        (loop for (path name) in jsfiles
                              for (path . val) = (assoc path model)
                              if val collect path))))))
         (buf (find-file-noselect pfile)))
    (unwind-protect
        (with-current-buffer buf
          (set-visited-file-name nil)
          (buffer-disable-undo)
          (erase-buffer)
          (insert json)
          (write-region (point-min) (point-max) pfile nil 'ok))
      (kill-buffer buf))
    (tern-prjfix-restart-server))
  (tern-prjfix-dialog-kill-buffer))

(defun tern-prjfix-dialog-kill-buffer (&optional model)
  (let ((cbuf (current-buffer))
        (win-num (length (window-list))))
    (when (and (not (one-window-p))
               (> win-num tern-prjfix-dialog-before-win-num))
      (delete-window))
    (kill-buffer cbuf)))

(defun tern-prjfix-restart-server ()
  (loop for i in (process-list)
        if (string= (process-name i) "Tern")
        do (quit-process i)))

(provide 'tern-dialog)
;;; tern-dialog.el ends here