license templates

data/mit.txt

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) {{current-year}} {{project-author}}
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

lspack.asd

@@ -1,8 +1,12 @@
-(asdf:defsystem "lspack"
+(defsystem "lspack"
   :author "Emre Akan"
   :description "Quickstart Common Lisp projects"
   :license "GPL-3.0"
   :version "0.0.1"
+  :depends-on ("uiop")
   :pathname "src/"
+  :serial t
   :components ((:file "package")
+               (:file "util")
+               (:file "license")
                (:file "starter")))

src/license.lisp

@@ -0,0 +1,109 @@
+(in-package :lspack)
+
+(defparameter *licenses* (make-hash-table))
+(defparameter *license-default-filename* "LICENSE")
+
+(defclass <license> ()
+  ((template-name :initarg :license-template-name
+                  :accessor license-template-name)
+   (file-name :initarg :license-file-name
+              :accessor license-file-name
+              :initform *license-default-filename*)
+   (writer :initform nil
+           :accessor license-writer)))
+
+(defun get-license (key)
+  (gethash key *licenses*))
+
+(eval-always
+ (defun set-license (key value)
+   (setf (gethash key *licenses*) value)))
+
+(eval-always
+ (defmacro deflicense (keys template-name &optional file-name)
+   (let ((sym (gensym "LICENSE")))
+     `(let ((,sym (make-instance '<license>
+                                 :license-template-name ,template-name
+                                 ,@(unless (null file-name)
+                                     `(:license-file-name file-name)))))
+        ,@(loop for key in (uiop:ensure-list keys)
+                collect `(set-license ,key ,sym))))))
+
+(deflicense :mit "mit.txt")
+
+(defmethod license-find-template ((license <license>))
+  (with-slots (template-name) license
+    (or (uiop:file-exists-p
+         (asdf:system-relative-pathname
+          :lspack
+          (uiop:merge-pathnames* template-name #P"data/")))
+        (uiop:file-exists-p
+         (uiop:xdg-data-home #P"lspack/data/" template-name)))))
+
+(defmethod license-read-template ((license <license>))
+  (uiop:if-let ((name (license-find-template license)))
+    (uiop:read-file-string name)))
+
+(defun template-find-args (template)
+  (loop with i = 0
+        while (< i (length template))
+        for arg = (uiop:if-let ((begin (search "{{" template :start2 i)))
+                    (uiop:if-let ((end (search "}}" template :start2 begin)))
+                      (prog1 (list (subseq template (+ begin 2) end) begin (+ end 2))
+                        (setf i (+ end 2)))))
+        while arg
+        collect arg))
+
+(defparameter *template-args* (make-hash-table :test 'equal))
+
+(defun define-template-arg (argument-name expander)
+  (setf (gethash argument-name *template-args*) expander))
+
+(defun get-arg-expander (arg)
+  (gethash arg *template-args*))
+
+(define-template-arg "current-year"
+    (lambda (p s)
+      (declare (ignore p))
+      `(format ,s "~D" (get-current-year))))
+
+(define-template-arg "project-author"
+    (lambda (p s)
+      `(format ,s "~A" (project-author ,p))))
+
+(defun generate-argument-writer (arg project-sym stream-sym)
+  (uiop:if-let ((arg-expander (get-arg-expander arg)))
+    (funcall arg-expander project-sym stream-sym)))
+
+(defun generate-writer-body (args project-sym template-sym stream-sym
+                             &optional (prev-end 0))
+  (if (null args)
+      `((write-string ,template-sym ,stream-sym :start ,prev-end))
+      (let ((arg (car args)))
+        (destructuring-bind (name begin end) arg
+          (cons `(write-string ,template-sym ,stream-sym :start ,prev-end
+                                                         :end ,begin)
+                (cons (generate-argument-writer name project-sym stream-sym)
+                      (generate-writer-body (cdr args) project-sym template-sym
+                                            stream-sym end)))))))
+
+(defun template-generate-writer (template-string)
+  (let ((args (template-find-args template-string))
+        (template-sym (gensym "TEMPLATE"))
+        (project-sym (gensym "PROJECT"))
+        (stream-sym (gensym "STREAM")))
+    `(lambda (,project-sym ,stream-sym)
+       (let ((,template-sym ,template-string))
+         ,@(generate-writer-body args project-sym template-sym stream-sym)))))
+
+(defmethod license-generate-writer ((license <license>))
+  (uiop:if-let (template (license-read-template license))
+    (setf (license-writer license)
+          (compile nil (template-generate-writer template)))))
+
+(defmethod license-ensure-writer ((license <license>))
+  (with-slots (writer) license
+    (if (functionp writer)
+        writer
+        (license-generate-writer license))))
+

src/starter.lisp

@@ -1,8 +1,8 @@
 (in-package :lspack)
 
 (defparameter *default-author* "")
-(defparameter *default-license* "")
+(defparameter *default-license* nil)
-(defparameter *default-pathname* "")
+(defparameter *default-pathname* "src")
 (defparameter *default-version* "0.0.0")
 
 (defclass <project> ()
@@ -24,7 +24,7 @@
    (license :initarg :project-license
             :accessor project-license
             :initform *default-license*
-            :type string)
+            :type (or keyword null))
    (version :initarg :project-version
             :accessor project-version
             :initform *default-version*
@@ -40,14 +40,14 @@
                  :project-name "my-project"
                  :project-author "name"
                  :project-description "a project"
-                 :project-pathname ""))
+                 :project-license :mit))
 
 (defmethod project-defsystem-write ((project <project>) stream)
   (with-slots (name author description license version pathname)
       project
     (fresh-line stream)
     (write-char #\( stream)
-    (format stream "asdf:defsystem ~S" name)
+    (format stream "defsystem ~S" name)
     (format stream "~&  :author ~S" author)
     (format stream "~&  :description ~S" description)
     (format stream "~&  :license ~S" license)
@@ -99,9 +99,23 @@
         (format out "(defpackage :~a~%  (:use :cl))~%" name))
       (format *error-output* "~&Created ~S" path))))
 
+(defmethod project-license-create ((project <project>))
+  (let ((license (get-license (project-license project))))
+    (unless (null license)
+      (let ((writer (license-ensure-writer license))
+            (license-file (uiop:merge-pathnames* (license-file-name license)
+                                                 (project-root project))))
+        (unless (null writer)
+          (with-open-file (out license-file :direction :output
+                                            :if-exists :supersede
+                                            :if-does-not-exist :create)
+            (funcall writer project out))
+          (format *error-output* "~&Created ~S" license-file))))))
+
 (defmethod project-start ((project <project>))
   (project-ensure-root project)
   (project-defsystem-create project)
+  (project-license-create project)
   (project-ensure-source-directory project)
   (project-create-package project))
 

src/util.lisp

@@ -0,0 +1,9 @@
+(in-package :lspack)
+
+(defmacro eval-always (&body body)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     ,@body))
+
+(defun get-current-year ()
+  (let ((now (get-universal-time)))
+    (nth-value 5 (decode-universal-time now))))