Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

283 lines (238 sloc) 9.318 kb
;;; shampoo-modes.el --- Shampoo FileOut routines
;;
;; Copyright (C) 2010 - 2012 Dmitry Matveev <me@dmitrymatveev.co.uk>
;;
;; This software is released under terms of the MIT license,
;; please refer to the LICENSE file for details.
(eval-when-compile (require 'cl))
(require 'shampoo-state)
(require 'shampoo-requests)
(require 'shampoo-response)
(require 'shampoo-utils)
(require 'shampoo-regexp)
;; Definitions and variables
(eval-when (compile load eval)
(defstruct shampoo-fileout-conf
item
splitby
directory
fproc
is-loaded))
(defvar *shampoo-fileout-scenarios* '())
;; File name manipulations
(defun shampoo-filename-as-is (name)
name)
(defun shampoo-filename-strip-package (name)
(let ((parsed (shampoo-regexp-parse name '(:Wd "\-" :Ws))))
(if parsed
(shampoo-regexp-extract 1 parsed)
name)))
(defun shampoo-filename-squash (name)
(shampoo-join-strings
""
(mapcar 'shampoo-capitalize (shampoo-split-string name))))
(defun shampoo-fileout-transform-filename (name rebuild-functions)
(let ((result name))
(dolist (func rebuild-functions)
(setq result (funcall func result)))
result))
(defun shampoo-fileout-build-filename (name conf)
(format
"%s%s.st"
(file-name-as-directory (shampoo-fileout-conf-directory conf))
(shampoo-fileout-transform-filename
name
(shampoo-fileout-conf-fproc conf))))
;; Fileout backup routines
(defun shampoo-fileout-format-timestamp ()
(destructuring-bind
(secs mins hour day month year dow dst zone)
(decode-time)
(format "%04d-%02d-%02d--%02d-%02d-%02d"
year month day hour mins secs)))
(defun shampoo-create-backup-dir (config)
(let ((backup-dir (concat (file-name-as-directory
(shampoo-fileout-conf-directory config))
"shampoo-backup")))
(when (not (file-exists-p backup-dir))
(make-directory backup-dir))
backup-dir))
(defun shampoo-fileout-backup (path conf)
(when (file-exists-p path)
(let* ((backup-dir (shampoo-create-backup-dir conf))
(base-name (file-name-sans-extension
(file-name-nondirectory path)))
(backup-name (format "%s%s-%s.st"
(file-name-as-directory backup-dir)
(shampoo-fileout-format-timestamp)
base-name)))
(copy-file path backup-name 0 t))))
;; Save to disk
(defun* shampoo-save-fileout (&key config)
(lexical-let ((conf config))
(lambda (response)
(when (not (shampoo-response-is-failure response))
(let* ((file (shampoo-msum
(shampoo-response-attr 'class response)
(shampoo-response-attr 'category response)))
(path (shampoo-fileout-build-filename file conf)))
(shampoo-fileout-backup path conf)
(with-temp-buffer
(insert (shampoo-response-enclosed-string response))
(write-region nil nil path))))
(when (shampoo-response-is-last-in-sequence response)
(message "Shampoo: file out complete")))))
;; User interaction functions
(defun* shampoo-fileout-ask (&key what from default)
(shampoo-ask :prompt (format "File out %s: " what)
:from from
:default default))
(defun shampoo-fileout-conf-get-splitby (fileout-subject)
(let ((type (car fileout-subject)))
(if (eql :class type)
"class"
(completing-read "Organize source code files by: "
'("class" "category")
nil t "category"))))
(defun shampoo-fileout-conf-get-directory ()
(read-directory-name "Store files into directory: "))
(defun shampoo-fileout-conf-get-fproc (fileout-subject)
(let ((type (car fileout-subject))
(funcs '(("Strip package prefix from file names? "
. shampoo-filename-strip-package)
("Remove space characters from file names? "
. shampoo-filename-squash))))
(if (eql :class type)
'(shampoo-filename-as-is)
(loop for each in funcs
when (yes-or-no-p (car each))
collect (cdr each)))))
;; Configuration setup functions
(defmacro* shampoo-fileout-fill (&key conf field provider)
(let ((selector
(intern
(concat "shampoo-fileout-conf-" (symbol-name field)))))
`(when (null (,selector ,conf))
(setf (,selector ,conf) ,provider))))
(defun shampoo-fileout-fill-conf (fileout-subject conf)
(shampoo-fileout-fill
:conf conf
:field splitby
:provider (shampoo-fileout-conf-get-splitby fileout-subject))
(shampoo-fileout-fill
:conf conf
:field directory
:provider (shampoo-fileout-conf-get-directory))
(shampoo-fileout-fill
:conf conf
:field fproc
:provider (shampoo-fileout-conf-get-fproc fileout-subject)))
(defun* shampoo-fileout-get-conf (type value)
(let* ((fileout-subject (cons type value))
(conf (shampoo-msum
(shampoo-fileout-script-for fileout-subject)
(shampoo-fileout-saved-for fileout-subject)
(make-shampoo-fileout-conf))))
(setf (shampoo-fileout-conf-item conf) value)
(shampoo-fileout-fill-conf fileout-subject conf)
(when (not (shampoo-fileout-conf-is-loaded conf))
(shampoo-fileout-try-save fileout-subject conf))
conf))
(defmacro mkmatcher (type-to-match value-to-match)
`(lexical-let ((type ,type-to-match)
(value ,value-to-match))
(lambda (fileout-subject)
(and (eql type (car fileout-subject))
(equal value (cdr fileout-subject))))))
(defun shampoo-fileout-namespace-match (namespace-name)
(mkmatcher :namespace namespace-name))
(defun shampoo-fileout-subject->matcher (fileout-subject)
(let ((type (car fileout-subject))
(value (cdr fileout-subject)))
(mkmatcher type value)))
(defun define-shampoo-fileout (matcher config)
(setf (shampoo-fileout-conf-is-loaded config) t)
(pushnew (cons matcher config) *shampoo-fileout-scenarios*))
(defun shampoo-fileout-conf-lookup (fileout-subject items)
(block root
(dolist (each items)
(when (funcall (car each) fileout-subject)
(return-from root (copy-shampoo-fileout-conf (cdr each)))))
nil))
(defun shampoo-fileout-script-for (fileout-subject)
(shampoo-fileout-conf-lookup
fileout-subject
*shampoo-fileout-scenarios*))
;; FileOut request producer functions
(defun shampoo-fileout-namespace (default)
(let ((conf (shampoo-fileout-get-conf
:namespace
(shampoo-fileout-ask
:what "namespace"
:from "*shampoo-namespaces*"
:default default)))
(id (shampoo-give-id)))
(shampoo-subscribe id (shampoo-save-fileout :config conf))
(shampoo-send-message
(shampoo-make-fileout-namespace-rq
:id id
:ns (shampoo-fileout-conf-item conf)
:split (shampoo-fileout-conf-splitby conf)))))
(defun shampoo-fileout-class (default)
(let ((conf (shampoo-fileout-get-conf
:class
(shampoo-fileout-ask
:what "class"
:from "*shampoo-classes*"
:default default)))
(id (shampoo-give-id)))
(shampoo-subscribe id (shampoo-save-fileout :config conf))
(shampoo-send-message
(shampoo-make-fileout-class-rq
:id id
:ns (shampoo-get-current-namespace)
:class (shampoo-fileout-conf-item conf)))))
(defun shampoo-fileout-class-category (default)
(let ((conf (shampoo-fileout-get-conf
:category
(shampoo-fileout-ask
:what "category"
:default default)))
(id (shampoo-give-id)))
(shampoo-subscribe id (shampoo-save-fileout :config conf))
(shampoo-send-message
(shampoo-make-fileout-category-rq
:id id
:ns (shampoo-get-current-namespace)
:cat (shampoo-fileout-conf-item conf)
:split (shampoo-fileout-conf-splitby conf)))))
;; Save/load fileout settings (for session)
(defun shampoo-fileout-try-save (fileout-subject conf)
(when
(yes-or-no-p
"Would you like to use this configuration for the further fileouts? ")
(let ((stored-conf (copy-shampoo-fileout-conf conf)))
(setf (shampoo-fileout-conf-is-loaded stored-conf) t)
(with-~shampoo~
(pushnew
(cons (shampoo-fileout-subject->matcher fileout-subject)
stored-conf)
(shampoo-current-fileout-configs ~shampoo~))))))
(defun shampoo-fileout-saved-for (fileout-subject)
(with-~shampoo~
(shampoo-fileout-conf-lookup
fileout-subject
(shampoo-current-fileout-configs ~shampoo~))))
;; Top-level fileout functions
(defun shampoo-fileout-current-namespace ()
(interactive)
(shampoo-fileout-namespace (shampoo-get-current-namespace)))
(defun shampoo-fileout-current-class ()
(interactive)
(shampoo-fileout-class (shampoo-get-current-class)))
(defun shampoo-fileout-current-class-category ()
(interactive)
(shampoo-fileout-class-category
(shampoo-get-current-class-category)))
(provide 'shampoo-fileout)
;; shampoo-fileout.el ends here.
Jump to Line
Something went wrong with that request. Please try again.