pit.el

;;; pit.el --- Manipulate pit data.

;; Copyright (C) 2008 Takeru Naito
;; Author: Takeru Naito <[email protected]>
;; Original: cho45 http://lowreal.rubyforge.org/pit/

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation; either version 2, or (at your
;; option) any later version.

;; This file is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; * Description
;;
;; pit.el manipulate Pit data.
;
;; See http://lowreal.rubyforge.org/pit/
;;
;; * Usage
;;
;; Just put the code like below into your .emacs:
;;
;; (require 'pit)
;;
;; (pit/get 'github.com)
;; (pit/get 'github.com '(require ((user . "Your github user name")
;;                                 (token . "Your github token"))))
;;
;; (pit/set 'github.com)
;; (pit/set 'github.com '(config ((user . "Your github user name")
;;                                (token . "Your github token"))))
;; (pit/set 'github.com '(data ((user . "Your github user name")
;;                              (token . "Your github token"))))

;;; Change Log:

;; 2008-12-19:
;;  * Initial import

(eval-when-compile (require 'cl))

(defun pit/x->bool (elt) (not (not elt)))

(defun pit/fold-left (proc init lis)
  (if lis (pit/fold-left proc (funcall proc init (car lis)) (cdr lis)) init))

(defvar pit/directory "~/.pit")
(defvar pit/config (expand-file-name
                    (format "%s/%s.yaml" pit/directory "pit")))

(defun pit/alist/update (base other)
  (mapcar (lambda (key)
            (or (assoc key other)
                (assoc key base)))
          (let ((hash (make-hash-table :test 'eql)))
            (loop for cons in (append base other)
                  for key = (car cons)
                  unless (gethash key hash)
                  do (puthash key key hash)
                  finally return
                  (loop for x being the hash-values in hash collect x)))))

(defvar pit/profile-regexp
  (rx bol
      (? (or "\"" "'"))
      "profile"
      (? (or "\"" "'"))
      ":"
      (* space)
      (? (or "\"" "'"))
      (group
       (+? nonl))
      (? (or "\"" "'"))
      (? "\r")
      eol))

(defun pit/profile ()
  (when (file-exists-p pit/config)
    (let* ((profile
            (with-temp-buffer
              (insert-file-contents pit/config)
              (when (re-search-forward pit/profile-regexp nil t)
                (match-string 1))))
           (profile/file
            (expand-file-name
             (format "%s/%s.yaml" pit/directory profile))))
      profile/file)))

(defun pit/keys/all-p (ret keys)
  (pit/x->bool
   (pit/fold-left (lambda (x y)
                (and x (assoc y ret) y))
              t keys)))

(defun pit/set (name &optional opts)
  (let ((profile (pit/load))
        (result
         (if (eq (car opts) 'data)
             (cadr opts)
           (mapcar
            (lambda (pair)
              (let ((key (car pair))
                    (value (cdr pair)))
                (cons key
                      (read-from-minibuffer
                       (format "\[%s\] %s: " name key)
                       value))))
            (or (cadr opts)
                (pit/get name))))))

    (when (eq (or (assoc 'config opts)
                  (assoc name profile))
              result)
      (message "No Changes"))

    (let*
        ((brand-new-profile
          (if (assoc name profile)
              (mapcar (lambda (prof)
                        (if (eq (car prof) name)
                            `(,name ,result)
                          prof))
                      profile)
            (append profile `((,name ,result)))))
         (names (mapcar (lambda (pair)
                          (car pair))
                        brand-new-profile)))

      (let ((profile/file (pit/profile)))
        (set-buffer (find-file-noselect profile/file))
        (unless (file-exists-p profile/file)
          (set-buffer-modified-p t)
          (save-buffer)
          (set-file-modes profile/file ?\600)))
      (erase-buffer)
      (insert "--- ")
      (mapc (lambda (name)
              (insert (format "\n%s: " (pit/yaml-quote (symbol-name name))))
              (mapcar (lambda (pair)
                        (insert
                         (format "\n  %s: %s "
                                 (pit/yaml-quote (symbol-name (car pair)))
                                 (pit/yaml-quote (cdr pair)))))
                      (cadr (assoc name brand-new-profile))))
            names)
      (insert "\n")
      (save-buffer)
      (kill-buffer))
    result))

(defun pit/get (name &optional opts)
  (let* ((profile (pit/load))
         (ret (cadr (assoc name profile))))

    (if (eq (car opts) 'require)
        (let*
            ((required (cadr opts))
             (keys (mapcar (lambda (cons)
                             (car cons))
                           required)))
          (when keys
            (if (pit/keys/all-p ret keys)
                ret
              (pit/set name `(config ,(pit/alist/update required ret))))))
      ret)))

(defun pit/load ()
  (let
      ((dirname (expand-file-name pit/directory)))
    (unless (file-accessible-directory-p dirname)
      (make-directory dirname)
      (set-file-modes dirname ?\700))
    (unless (file-exists-p pit/config)
       (set-buffer (find-file-noselect pit/config))
       (insert "--- \nprofile: default\n")
       (save-buffer)
       (kill-buffer)
       (set-file-modes pit/config ?\600)))
  (let ((profile/file (pit/profile))
        result)
    (when (and profile/file
               (file-exists-p profile/file))
      (with-temp-buffer
        (insert-file-contents profile/file)
        (let ((regexp1 "^\\([\"']?\\)\\(.+?\\)\\1 *: *$")
              (regexp2
               "^ +\\(\\([\"']?\\)\\(?:.+?\\)\\2\\) *: *\\(\\([\"']?\\)\\(?:.*?\\)\\4\\) *$"))
          (while (re-search-forward regexp1 nil t)
            (let ((name (intern (pit/yaml-unquote (match-string 2))))
                  (bound (save-excursion (re-search-forward regexp1 nil t)))
                  config)
              (while (re-search-forward regexp2 bound t)
                (let* ((raw-key (match-string 1))
                       (raw-value (match-string 3))
                       (key (intern (pit/yaml-unquote raw-key)))
                       (value (pit/yaml-unquote raw-value)))
                  (setq config (append config `((,key . ,value))))))
              (setq result (append result `((,name . (,config)))))))))
      result)))

(defun pit/yaml-quote (object)
  (cond
   ((null object)
    "~")
   ((stringp object)
    (cond
     ((equal object "")
      "''")
     ((string-match "[\"'\n]" object)
      (format
       "\"%s\""
       (replace-regexp-in-string
        "\n" "\\\\n"
        (replace-regexp-in-string "\"" "\\\\\"" object))))
     ((string-match "\\`[^0-9A-Za-z_]\\|[[:space:]]\\|:\\'" object)
      (format "'%s'" object))
     (t object)))))

(defun pit/yaml-unquote (string)
  (setq string (replace-regexp-in-string
                "\\`[[:space:]]+\\|[[:space:]]+\\'" "" string))
  (cond
   ((string-match "\\`'\\(.*\\)'\\'" string)
    (replace-regexp-in-string "''" "'" (match-string 1 string)))
   ((string-match "\\`\"\\(.*\\)\"\\'" string)
    (replace-regexp-in-string
     "\\\\\"" "\""
     (replace-regexp-in-string "\\\\n" "\n" (match-string 1 string))))
   (t
    (unless (or (equal string "~")
                (equal string ""))
      string))))

;;; Test
(defvar pit/test-profile-yaml
  "---
profile: default
")

(defvar pit/test-profile-yaml-quoted
  "---
\"profile\": 'default'"
)


(dont-compile
  (when (fboundp 'expectations)
    (expectations
      (desc "pit/profile")
      (expect "default"
        (with-temp-buffer
          (insert pit/test-profile-yaml)
          (goto-char (point-min))
          (when (re-search-forward pit/profile-regexp nil t)
            (match-string 1))))

      (expect "default"
        (with-temp-buffer
          (insert pit/test-profile-yaml-quoted)
          (goto-char (point-min))
          (when (re-search-forward pit/profile-regexp nil t)
            (match-string 1))))
      )))


(provide 'pit)

;;; pit.el ends here

;; Local Variables:
;; mode: emacs-lisp
;; coding: utf-8-unix
;; indent-tabs-mode: nil
;; End: