Simple project template manager for Common Lisp.

tmpl.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
  (ros:ensure-asdf)
  #+quicklisp(ql:quickload '(:djula :cl-ppcre :cl-fad) :silent t))
  

(defpackage :ros.script.foo.3843456484
  (:use :cl))
(in-package :ros.script.foo.3843456484)

(defun quit (&optional code)
  ;; This group from "clocc-port/ext.lisp"
  #+allegro (excl:exit code)
  #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
  #+cmu (ext:quit code)
  #+cormanlisp (win32:exitprocess code)
  #+gcl (lisp:bye code)                     ; XXX Or is it LISP::QUIT?
  #+lispworks (lw:quit :status code)
  #+lucid (lcl:quit code)
  #+sbcl (sb-ext:exit :code code)
  ;; This group from Maxima
  #+kcl (lisp::bye)                         ; XXX Does this take an arg?
  #+scl (ext:quit code)                     ; XXX Pretty sure this *does*.
  #+(or openmcl mcl) (ccl::quit)
  #+abcl (cl-user::quit)
  #+ecl (si:quit)
  ;; This group from <[email protected]>
  #+poplog (poplog::bye)                    ; XXX Does this take an arg?
  #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbc
        kcl scl openmcl mcl abcl ecl)
  (error 'not-implemented :proc (list 'quit code)))

(defun show-desc ()
  (format t "tmpl.ros [template] [new-project-name]~%"))
(defun show-nil-system (name)
  (format t "Not found system ~a.~%" name))
(defun show-nil-template (path)
  (format t "Not found ~a.~%" path))

(defvar *template-registry* (truename "./"))
(defparameter *environment* '((:project-name . "new-project")))
(defparameter *project-dir* nil)
(defparameter *new-dir* nil)

(defun complete (str)
  (loop for as in *environment*
        do (setf str
                 (ppcre:regex-replace
                   (format nil "\\{\\{\\s*~a\\s*\\}\\}" (string-downcase (symbol-name (car as))))
                   str
                   (cdr as))))
  str)

(defmacro deftemplate (template-name var-list tmp-list static-list)
  `(progn
     (push (cons :template-name (string-downcase (symbol-name ',template-name))) *environment*)
     ;; input and set each variable.
     ,@(loop for var in var-list
             collect `(let* ((var-name (first ',var))
                             (var-name-keyword (intern (symbol-name var-name) :keyword))
                             (var-initform (second ',var))
                             (var-prompt (getf ',var :prompt)))
                        (format t "~a [~a]: "
                                (if var-prompt var-prompt var-name)
                                var-initform)
                        (force-output)
                        (let ((input (read-line *standard-input* nil nil)))
                          (when (null input)
                            (quit 1))
                          (push (cons var-name-keyword
                                      (if (string= "" input)
                                          var-initform
                                          input))
                                *environment*))))
     (let ((*default-pathname-defaults* (pathname ,*project-dir*)))
       ;; process each template.
       ,@(loop for tmp in tmp-list
               collect `(let ((candidates (directory ,tmp))) ;; candidate pathnames for tmp
                          (loop for tmp-path in candidates
                                do (let* ((completed (complete (namestring tmp-path)))
                                          (rel (enough-namestring completed *project-dir*)) ;; relative path from template directory
                                          (from-new-dir (merge-pathnames rel *new-dir*))) ;; absolute path of the relative from new project directory
                                     (format t "Create: ~a~%" from-new-dir)
                                     ;; create directories in new project directory.
                                     (ensure-directories-exist (directory-namestring from-new-dir))
                                     ;; render templates into new project directory.
                                     (with-open-file (s from-new-dir :direction :output)
                                       (apply #'djula:render-template*
                                         `(,(djula:compile-template* tmp-path)
                                           ,s
                                           ,@(loop for as in *environment*
                                                   collect (car as)
                                                   collect (cdr as)))))))))
       ;; copy each static file.
       ,@(loop for static in static-list
               collect `(let ((candidates (directory ,static)))
                          (loop for static-path in candidates
                                do (let* ((rel (enough-namestring static-path *project-dir*))
                                          (from-new-dir (merge-pathnames rel *new-dir*)))
                                     (format t "Copy: ~a~%" from-new-dir)
                                     (ensure-directories-exist (directory-namestring from-new-dir))
                                     (uiop:copy-file static-path from-new-dir))))))))

(defun find-template (name)
  (let* ((path (merge-pathnames name *template-registry*))
         (pathdir (cl-fad:pathname-as-directory path)))
    (if (and (probe-file path)
             (cl-fad:directory-exists-p pathdir))
      pathdir
      (multiple-value-bind
        (foundp found-system pathname previous previous-time)
        (asdf:locate-system name)
        (declare (ignore foundp found-system previous previous-time))
        (when pathname
          (directory-namestring pathname))))))

(defun main (&rest argv)
  (declare (ignorable argv))
  (let ((template (first argv))
        (new-project (second argv)))
    ;; check command line arguments
    (when (or (null template)
             (null new-project))
      (show-desc)
      (quit 1))
    ;; check package is exists
    (let ((pathname (find-template template)))
      (unless pathname
        (show-nil-system template)
        (quit 1))

      (let* ((project-dir (directory-namestring pathname))
             (template-file (merge-pathnames project-dir ".template.lisp")))
        (unless (probe-file template-file)
          (show-nil-template template-file)
          (quit 1))

        (djula:add-template-directory project-dir)
        (setf *project-dir* project-dir
              *new-dir* (ensure-directories-exist
                          (merge-pathnames
                            (format nil "~a/" new-project)
                            (truename "./"))))
        (push (cons :project-name new-project) *environment*)
        (load template-file)))))
;;; vim: set ft=lisp lisp: