common-lisp/roswell.roswell
1
0
Fork 0
mirror of https://github.com/roswell/roswell.git synced 2026-09-10 07:16:17 -04:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

purge effect of template branch.

Browse source
This commit is contained in:
SANO Masatoshi 2016-04-21 20:13:14 +09:00
parent bab72a39a2
commit 51a521055e
6 changed files with 2 additions and 464 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

71
documents/ros-template.md
View file

@ -1,71 +0,0 @@
# Synopsis
**ros template** [add|rm|list|show] [OPTIONS] [TEMPLATE [ARGS...]]
Register, manage and remove the templates.
The format of ARGS is same as the lambda list except the following translation:
* &key, &optional, &rest corresponds to --key, --optional, --rest, respectively.
* Abbreviation as -k, -o, -r are available.
* Each argument is separated by --, instead of being surrounded by parentheses.
* Optional and keyword arguments can have a default value. When no defauilt
value is specified, it implies an empty string.
# Examples
The following example shows how to register a template file (an asdf system definition) named *tmpl.asd*, then instantiate the template with some arguments.
```
$ cat tmpl.asd
(asdf:defsystem NAME :author "AUTHOR" :depends-on DEP :short-description "library by AUTHOR.")
$ ros template add tmpl.asd NAME AUTHOR --optional DEP "(:alexandria)"
$ ros init result.asd tmpl.asd bob-utilities Bob
Successfully generated: result.asd
$ cat result.asd:
(asdf:defsystem bob-utilities :author "Bob" :depends-on (:alexandria) :short-description "library by Bob.")
```
Notice the arguments are READ. Thus you may use "#." readmacro in order to evaluate the
arguments when the template is instantiated. For example,
```
$ echo $USER
Bob
$ ros init result.asd tmpl.asd bob-utilities '#.(uiop:getenv "USER")'
$ cat result.asd:
(asdf:defsystem bob-utilities :author "Bob" :depends-on (:alexandria) :short-description "library by Bob.")
```
The results are PRINCed, so the results are not escaped with "".
If you want the results to be escaped, it should be done in the template (as in "AUTHOR").
# Subcommands
add
: Registers a file *TEMPLATE*.
list
: Shows the list of the registered templates.
show
: Describes the contents of *TEMPLATE* which is already registered.
rm
: Ensures that a template *TEMPLATE* is removed.
# Options for *ros template add*
* -f,--force : Overwrites the existing template with the same name without asking
* -r,--recursive : register the directory recursively. TEMPLATE should be a directory in order to make this option meaningful.
* --name NAME : register the template with a given name, not the original filename.
# Misc
Registered templates are stored in directory $ROSWELL_HOME/templates/ .
# SEE ALSO
_ros_(1)
_ros-init_(1)

2
lisp/Makefile.am
View file

@ -1,3 +1,3 @@
roslispdir = $(datadir)/common-lisp/source/$(PACKAGE)
roslisp_DATA = $(wildcard *.lisp) $(wildcard *.ros) $(wildcard *.asd) default
roslisp_DATA = $(wildcard *.lisp) $(wildcard *.ros) $(wildcard *.asd)

13
lisp/default
View file

@ -1,13 +0,0 @@
#!/bin/sh
#|-*- mode:lisp -*-|#
#| <Put a one-line description here>
exec ros -Q -- $0 "$@"
|#
;;; vim: set ft=lisp lisp:
;; created DATETIME
(defpackage :ros.script.NAME.DATETIME
(:use :cl))
(in-package :ros.script.NAME.DATETIME)
(defun main (&rest argv)
(declare (ignorable argv)))

158
lisp/init.ros
View file

@ -7,167 +7,11 @@ exec ros -Q -m roswell -L sbcl-bin -- $0 "$@"
#-ros.util
(ros:include "util")
(unless (find-package :trivia)
(ql:quickload :trivia :silent t))
(defpackage :ros.sub.init
(:use :cl :ros.util :trivia)
(:export
#:*filename*))
(:use :cl :ros.util))
(in-package :ros.sub.init)
(defun usage ()
(format *error-output* "Usage: ros init FILENAME [TEMPLATE [ARGS...]]")
(format *error-output* "
TEMPLATE is defaulted to \"default\".
When TEMPLATE is missing and FILENAME matches the name of some template, it overrides the default.
When FILENAME is \"-\", it renders the output to stdout.
")
(ros:quit 1))
(defvar *filename*)
(defvar *template-dir* (merge-pathnames "templates/" (homedir)))
(defun main (main cmd &optional filename (template (when filename (find-template-or-lose filename))) &rest argv)
(assert (equal main "main"))
(assert (equal cmd "init"))
(ensure-directories-exist *template-dir*)
(match filename
(nil
(usage))
("-"
(let ((*filename* "STDOUT"))
(render *standard-output* template
(mapcar #'read-and-reprint-string argv))))
(_
(let* ((filename (pathname filename))
(*filename* (if (not (pathname-type filename))
(make-pathname :type "ros" :defaults filename)
filename)))
(with-open-file (s *filename* :direction :output :if-exists :supersede :if-does-not-exist :create)
(render s template
(mapcar #'read-and-reprint-string argv)))
(format t "Instantiated a template ~a into ~a~%" template *filename*)))))
(defun read-and-reprint-string (string)
(princ-to-string (read-from-string string)))
(defun find-template-or-lose (filename)
"try to find a tempalte with a given filename, return \"default\" when failed"
(let ((path (merge-pathnames filename *template-dir*)))
(if (probe-file path)
filename
"default")))
(defun read-file (path)
(with-open-file (s path :if-does-not-exist :error)
(loop for o = (read s nil '+eof+)
until (eq o '+eof+)
collect o)))
(defun render (s template argv)
(handler-case
(let ((abs (merge-pathnames template *template-dir*)))
(bind-arguments s (first (read-file abs)) argv))
(file-error ()
(format t "Template file ~a does not exist" template))))
(defun bind-arguments (s metadata argv0)
(let ((argv (copy-list argv0)))
(ematch metadata
((list :arguments (list required optional keywords rest) :source src)
(let (binding)
(dolist (var required)
(push (cons var
(or (pop argv)
(progn
(format *error-output*
"Insufficient number of arguments in ~a for ~a: ~
~a needed, ~a present~%"
argv0 required (length required) (length argv0))
(ros:quit 1))))
binding))
(dolist (opt optional)
(ematch opt
((list* var default _)
(push (cons var (or (pop argv) (read-and-reprint-string default)))
binding))))
(dolist (key keywords)
(ematch key
((list* var default _)
(push (cons var (string-getf argv (shell-keyword var)
(read-and-reprint-string default)))
binding)
(string-remf argv (shell-keyword var)))))
(when rest
(push (cons rest argv) binding))
(princ (render-variables (reverse binding) src) s))))))
(defun shell-keyword (var)
(format nil "--~(~a~)" var))
(defun string-getf (place indicator &optional default)
(match place
((list* key value rest)
(if (string-equal key indicator)
value
(string-getf rest indicator default)))
(nil
default)))
(defun string-remf (place indicator)
(match place
((list* key value rest)
(if (string-equal key indicator)
(string-remf rest indicator)
(list* key value
(string-remf rest indicator))))
(nil nil)))
(defun render-variables (bindings src)
;; FIXME: list-based implementation, does not scale to larger files
(let ((src (coerce src 'list)))
(dolist (binding bindings (coerce src 'string))
(ematch binding
((cons var val)
;; FIXME: irregular behavior might occur when one variable name is
;; included as a part of the other variable, e.g. var1=FOO and
;; var2=FOOBAR.
;;
;; Similarly, further undefined behavior might exists when the
;; result of replacement contains other variables, e.g., var1=FOO is
;; replaced with a string BAR, and var2=BAR.
(setf src (render-variable var val src)))))))
(defun render-variable (var val src)
"search for a matching substring from the beginning, and replacing the elements, backtracking as needed."
(loop for sub on src
while (nthcdr (length var) sub)
for pos = (search var sub :end2 (length var))
do
(when pos
(assert (= pos 0))
(cond
((< (length var) (length val))
(dotimes (i (- (length val) (length var)))
;; (a b c d) -> (a a b c d)
(push (car sub) (cdr sub))))
((> (length var) (length val))
(dotimes (i (- (length var) (length val)))
;; (a b c d) -> (b b c d)
(setf (car sub) (cadr sub))
;; (b [b] c d) -> (b c d)
;; [b] is removed, so the first cons cell does not change
(pop (cdr sub)))))
(replace sub val)))
src)
#+nil
(defun main (subcmd cmd &optional name &rest r)
(declare (ignore cmd))
(if (and (equal subcmd "main") name)

7
lisp/setup.ros
View file

@ -39,13 +39,6 @@ exec ros -Q -L sbcl-bin -- $0 "$@"
:collect "--load"
:collect (format nil "~A" i))
" dump output -f roswell")
t nil)
(ros:roswell `("template" "add" "-f"
,(namestring (make-pathname :name "default"
:type nil
:defaults *load-pathname*))
"--optional" "NAME" "'#.(pathname-name (merge-pathnames ros.sub.init:*filename*))'"
"--" "DATETIME" "'#.(get-universal-time)'")
t nil))))
(push :ros.sub.setup *features*)

215
lisp/template.ros
View file

@ -1,215 +0,0 @@
#!/bin/sh
#|-*- mode:lisp -*-|#
#| Register a file as a template.
exec ros -Q -m roswell -L sbcl-bin -- $0 "$@"
|#
#|
ros [options] template add [OPTIONS] TEMPLATE ARGS...
* each argument is separated by --, instead of being surrounded by parentheses.
* &key, &optional, &rest corresponds to --key, --optional, --rest, respectively.
* Abbreviation as -k, -o, -r are available.
|#
#-ros.util
(ros:include "util")
(unless (find-package :trivia)
(ql:quickload :trivia :silent t))
(defpackage :ros.script.template
(:use :cl :ros.util :trivia :alexandria))
(in-package :ros.script.template)
(defun usage ()
(format *error-output* "Usage: ros [options] template [SUBCOMMAND] [[OPTIONS] TEMPLATE ARGS...]~%")
(format *error-output* "subcommands:~%")
(finish-output *error-output*) (finish-output)
(format t "~&~{~(~a~)~%~}" '(add rm show list)) ;; this also serves as the bash completion candidates
(ros:quit 1))
(defvar *template-dir* (merge-pathnames "templates/" (homedir)))
(defun main (&rest argv)
(ensure-directories-exist *template-dir*)
(match argv
((list* _ _ "list" _)
(list-templates))
((list _ _ "add")
(list-templates :files))
((list _ _ "show")
(list-templates :templates))
((list _ _ "rm")
(list-templates :templates))
((list* _ _ "add" argv)
(add-template argv))
((list* _ _ "rm" argv)
(rm-template argv))
((list* _ _ "show" argv)
(show-template argv))
(_
(usage))))
;;; ros template add
(defun slurp (stream)
"http://www.ymeme.com/slurping-a-file-common-lisp-83.html"
(let ((seq (make-array (file-length stream)
:element-type 'character
:fill-pointer t)))
(setf (fill-pointer seq) (read-sequence seq stream))
seq))
(defun read-file-to-string (path)
(with-input-from-file (s path)
(slurp s)))
(defun read-file (path)
(with-input-from-file (s path)
(loop for o = (read s nil '+eof+)
until (eq o '+eof+)
collect o)))
(defvar *if-exists* :error)
(defvar *name* nil)
(unless (ignore-errors (symbol-function 'add-template))
(defun add-template (args)
(match args
((list* "-f" rest) (let ((*if-exists* :overwrite)) (add-template rest)))
((list* "--force" rest) (let ((*if-exists* :overwrite)) (add-template rest)))
((list* "--r" rest) (error "not implemented yet") #+nil (add-template-recursive rest))
((list* "--recursive" rest) (error "not implemented yet") #+nil (add-template-recursive rest))
((list* "--name" *name* rest) (add-template rest))
((list* template args)
(assert (probe-file template))
(with-open-file (s (make-pathname :directory (pathname-directory *template-dir*)
:defaults (or *name* template))
:direction :output
:if-does-not-exist :create
:if-exists *if-exists*)
(write (list :arguments (parse-args args)
:source (read-file-to-string template))
:stream s)))))
)
(defvar *required*)
(defvar *optional*)
(defvar *rest*)
(defvar *keywords*)
(defun parse-args (args)
(let (*required* *optional* *rest* *keywords*)
(parse-required args)
(list *required* *optional* *rest* *keywords*)))
(defun parse-required (args)
(ematch args
((list* "--" _) (error "unexpected use of --"))
((list* "--key" rest) (parse-keywords rest))
((list* "-k" rest) (parse-keywords rest))
((list* "--optional" rest) (parse-optional rest))
((list* "-o" rest) (parse-optional rest))
((list* "--rest" rest) (parse-rest rest))
((list* "-r" rest) (parse-rest rest))
((list* name rest) (push name *required*) (parse-required rest))
(nil )))
(defun parse-optional (args)
(symbol-macrolet ((p1 (push (list name "") *optional*))
(p2 (push (list name default) *optional*)))
(ematch args
((list* "--" _) (error "unexpected use of --"))
((list* name "--key" rest) p1 (parse-keywords rest))
((list* name "-k" rest) p1 (parse-keywords rest))
((list* name "--rest" rest) p1 (parse-rest rest))
((list* name "-r" rest) p1 (parse-rest rest))
((list* name "--" rest) p1 (parse-optional rest))
((list name) p1)
((list* name default "--key" rest) p2 (parse-keywords rest))
((list* name default "-k" rest) p2 (parse-keywords rest))
((list* name default "--rest" rest) p2 (parse-rest rest))
((list* name default "-r" rest) p2 (parse-rest rest))
((list* name default "--" rest) p2 (parse-optional rest))
((list name default) p2))))
(defun parse-keywords (args)
(symbol-macrolet ((p1 (push (list name "") *keywords*))
(p2 (push (list name default) *keywords*)))
(ematch args
((list* "--" _) (error "unexpected use of --"))
((list* name "--rest" rest) p1 (parse-rest rest))
((list* name "-r" rest) p1 (parse-rest rest))
((list* name "--" rest) p1 (parse-keywords rest))
((list name) p1)
((list* name default "--rest" rest) p2 (parse-rest rest))
((list* name default "-r" rest) p2 (parse-rest rest))
((list* name default "--" rest) p2 (parse-keywords rest))
((list name default) p2))))
(unless (ignore-errors (symbol-function 'parse-rest))
(defun parse-rest (args)
(ematch args
((list* "--" _) (error "unexpected use of --"))
((list* _ rest) (error ">2 arguments after rest arguments"))
((list name) (setf name *rest*))))
)
;;; ros template rm
(defun rm-template (argv)
(let ((argv (mapcar #'pathname argv)))
(assert (every (lambda (path) (null (pathname-directory path))) argv)
nil "do not specify a template file in a subdirectory of a directory template")
(dolist (path argv)
(let ((path (merge-pathnames path *template-dir*)))
(when (probe-file path)
(format t "; deleting a template ~a~%" path)
(delete-file path))))))
(defun show-template (argv)
(dolist (path (mapcar #'pathname argv))
(handler-case
(let ((abs (merge-pathnames path *template-dir*)))
(ematch (first (read-file abs))
((list :arguments (list required optional keywords rest) :source src)
(format t "~&; Template -- ~a ~{~a ~}~
~@[&optional ~{~a ~}~] ~
~@[&key ~{~a ~}~] ~
~@[&rest ~{~a ~}~]~%"
path required optional keywords rest)
(format t "~&; Absolute path -- ~a~%" abs)
(format t "; Template Body~%")
(format t "; ====== starts from this line =====~%~a~%" src)
(format t "; ====== ends here =====~%"))))
(file-error ()
(format t "Template file ~a does not exist" path)))))
(defun list-templates (&optional completion-style)
(flet ((output ()
(format t "~{~a~%~}"
(sort (remove "default"
(mapcar #'enough-namestring
(directory (make-pathname :name :wild :type :wild)))
:test #'string=)
#'string<))))
(match completion-style
(nil
;; normal output as a "ros template list" subcommand
(let ((*default-pathname-defaults* *template-dir*))
(output)))
(:files
;; list files as the candidates
(format *error-output* "error: Missing arguments. Candidates:~%")
(finish-output *error-output*)
(output))
(:templates
(format *error-output* "error: Missing arguments. Candidates:~%")
(finish-output *error-output*)
(let ((*default-pathname-defaults* *template-dir*))
(output))))))
;;; vim: set ft=lisp lisp: