Generate new Lisp projects

new-project.lisp

(defpackage #:snippets/new-project
  (:use #:cl)
  (:export
   #:*projects-directory*
   #:new-project))

(in-package #:snippets/new-project)

(defvar *projects-directory*
  (merge-pathnames
   (make-pathname :directory '(:relative "quicklisp" "local-projects"))
   (user-homedir-pathname)))

(defvar *new-project-pprint-dispatch*
  (let ((table (copy-pprint-dispatch)))
    (set-pprint-dispatch '(eql asdf:defsystem) 'pprint-defsystem-symbol 0 table)
    (set-pprint-dispatch '(eql uiop:define-package) 'pprint-define-package-symbol 0 table)
    (set-pprint-dispatch '(cons (eql asdf:defsystem)) 'pprint-defsystem-form 0 table)
    (set-pprint-dispatch '(cons (eql uiop:define-package)) 'pprint-define-package-form 0 table)
    ;; SBCL's printing of simple-base-strings is pretty ugly.
    (set-pprint-dispatch 'simple-base-string 'pprint-simple-base-string 0 table)
    table))

(defvar *project-name*)

(defgeneric generate (file))
(defgeneric project-property (unit field))

(defmacro define-project-property (unit field &body forms)
  (multiple-value-bind (unit unit-specializer)
      (if (keywordp unit)
          (values (gensym) `(eql ',unit))
          (values unit 't))
    (multiple-value-bind (field field-specializer)
        (if (keywordp field)
            (values (gensym) `(eql ',field))
            (values field 't))
      `(defmethod project-property ((,unit ,unit-specializer)
                                    (,field ,field-specializer))
         (declare (ignorable ,unit ,field))
         ,@forms))))

(define-project-property :file designator
  (multiple-value-bind (name type)
      (ecase designator
        (:system (values *project-name* "asd"))
        (:main (values *project-name* "lisp"))
        (:all (values "all" "lisp")))
    (merge-pathnames
     (make-pathname :name name :type type
                    :directory (list :relative *project-name*))
     *projects-directory*)))

(define-project-property :project :name
  (string-capitalize *project-name*))

(define-project-property :system :name
  (make-symbol (string-upcase *project-name*)))

(define-project-property :module :all
  (format nil "~A/~A" *project-name* "all"))

(define-project-property :package :all
  (make-symbol (string-upcase (project-property :module :all))))

(define-project-property :package :system
  (project-property :system :name))

(define-project-property :module :main
  (format nil "~A/~A" *project-name* *project-name*))

(define-project-property :package :main
  (make-symbol (string-upcase (project-property :module :main))))

(defun new-project (name)
  (let ((*project-name* name))
    (dolist (file '(asd all main))
      (generate file))))

(defun call-with-generated-file (file-designator &rest forms)
  (let ((filename (project-property :file file-designator)))
    (ensure-directories-exist filename)
    (with-open-file (stream filename
                            :direction :output
                            :if-does-not-exist :create
                            :if-exists :supersede)
      (print-header (project-property :project :name) stream)
      (with-standard-io-syntax
        (let ((*print-case* :downcase)
              (*print-pprint-dispatch* *new-project-pprint-dispatch*))
          (dolist (form forms)
            (pprint form stream)
            (terpri stream)))))))

(defun pprint-defsystem-symbol (stream symbol)
  (declare (ignore symbol))
  (write-string "asdf:defsystem" stream))

(defun pprint-define-package-symbol (stream symbol)
  (declare (ignore symbol))
  (write-string "uiop:define-package" stream))

(defun pprint-defsystem-form (stream form)
  (pprint-logical-block (stream form :prefix "(" :suffix ")")
    (write (pprint-pop) :stream stream)
    (pprint-exit-if-list-exhausted)
    (write-char #\Space stream)
    (pprint-indent :block 3 stream)
    (pprint-newline :fill)
    (write (pprint-pop) :stream stream)
    (pprint-exit-if-list-exhausted)
    (pprint-indent :block 1 stream)
    (loop
     (let ((key (pprint-pop)))
       (pprint-newline :mandatory stream)
       (write key :stream stream)
       (pprint-exit-if-list-exhausted))
     (let ((value (pprint-pop)))
       (write-char #\Space stream)
       (write value :stream stream)
       (pprint-exit-if-list-exhausted)))))

(defun pprint-define-package-form (stream form)
  (format stream
          "~:<~W~^ ~3I~:_~W~^~1I~@{~:@_~:<~^~W~^ ~:I~@_~@{~W~^ ~_~}~:>~}~:>"
          form))

(defun pprint-simple-base-string (stream string)
  (write (make-array (length string)
                     :element-type 'character
                     :initial-contents string)
         :stream stream))

(defun print-header (name stream)
  (format stream
          ";;;; +----------------------------------------------------------------+~%~
           ;;;; | ~62A |~%~
           ;;;; +----------------------------------------------------------------+~%"
          name))

(defmacro with-generated-file ((file-designator) &body body)
  `(call-with-generated-file ',file-designator
                             ,@body))

(defmethod generate ((file (eql 'asd)))
  (let ((system-name (project-property :system :name))
        (all-module (project-property :module :all)))
    (with-generated-file (:system)
      `(asdf:defsystem ,system-name
         :class :package-inferred-system
         :defsystem-depends-on ("asdf-package-system")
         :depends-on (,all-module)))))

(defmethod generate ((file (eql 'all)))
  (let ((all-package (project-property :package :all))
        (system-package (project-property :package :system))
        (main-package (project-property :package :main)))
    (with-generated-file (:all)
      `(uiop:define-package ,all-package
           (:nicknames ,system-package)
         (:use-reexport ,main-package)))))

(defmethod generate ((file (eql 'main)))
  (let ((main-package (project-property :package :main)))
    (with-generated-file (:main)
      `(defpackage ,main-package
         (:use #:cl)
         (:export))
      `(in-package ,main-package))))