Inital Commit

5 files changed, 220 insertions, 0 deletions

diff --git a/README.md b/README.md
new file mode 100644
index 0000000..bfe785c
--- /dev/null
+++ b/README.md
@@ -0,0 +1,66 @@
+# `def`
+
+A stupid project to dull the pain of using a few of CL's built-in `def*` forms.
+
+## `def:var`
+
+Isn't it annoying that, if you want to leave a `defvar`-defined
+special variable uninitialized at the top-level, then you're not
+allowed to give that variable a docstring? 
+
+Sure, you can always 
+
+    (setf (documentation *my-speical* 'variable) "oh good, docs")
+    
+but that's irritating too.
+
+Enter `def:var`
+
+
+    (def:var *oh-so-special* :doc "It's oh-so-special")
+    
+Of course, you may still initialize the variable:
+
+    (def:var *oh-so-special* :init (random 10) :doc "It's oh-so-special")
+    
+## `def:const` 
+
+Even more obnoxious is the behavior of `defconst` whenever you `C-c
+C-c` in SLIME. You nearly always find yourself invoking a `CONTINUE`
+restart when, according to common sense, you should not have had to.
+
+Well no more! 
+
+    (def:const +its-ten+ 10 "It's just the number 10")
+    
+If you re-evaluate that form, then nothing annoying happens. Of
+course, the form still expands out to `defconstant` so that a
+condition signals whenever you try to `setf` the name. 
+
+## `def:class`
+
+Admittedly, this one is less justfifed. There's already the extremely
+elaborate `defclass/std` in the `defclass-std` system available
+through quicklisp.  But I think `defclass/std` is a little *too*
+thorough and ends up getting in its own way.
+
+The case for using a macro like this is that, well, most classes are
+defined in a very repetitive way.  This macro just saves you some
+work:
+
+    (def:class pt () 
+      (x y z :prefix :type real :initform 0)
+      (uuid :ro :type integer :initform (make-uuid) :documentation "A unique ID")
+      :documentation "A point in real 3d space")
+      
+The above would expand out into
+
+    (DEFCLASS PT NIL
+      ((X :ACCESSOR PT-X :INITARG :X :TYPE REAL :INITFORM 0)
+       (Y :ACCESSOR PT-Y :INITARG :Y :TYPE REAL :INITFORM 0)
+       (Z :ACCESSOR PT-Z :INITARG :Z :TYPE REAL :INITFORM 0)
+       (UUID :READER UUID :INITARG :UUID :TYPE INTEGER :INITFORM
+             (MAKE-UUID) :DOCUMENTATION "A unique ID"))
+      (:DOCUMENTATION "A point in real 3d space"))
+      
+See `def:class`'s docstring for details.
diff --git a/def.asd b/def.asd
new file mode 100644
index 0000000..bd760e1
--- /dev/null
+++ b/def.asd
@@ -0,0 +1,11 @@
+;;;; def.asd
+
+(asdf:defsystem #:def
+  :description "Macros Making def* forms nicer to use."
+  :author "colin <colin@cicadas.surf>"
+  :license  "Unlicense"
+  :version "0.0.1"
+  :serial t
+  :components ((:file "package")
+               (:file "util")
+               (:file "def")))
diff --git a/def.lisp b/def.lisp
new file mode 100644
index 0000000..9944505
--- /dev/null
+++ b/def.lisp
@@ -0,0 +1,101 @@
+;;;; def.lisp
+
+(in-package #:def)
+
+(defmacro var (name &key doc (init nil initp))
+  "DEFVAR with optional documentation and optional initform. Lets you
+easily document uninitialized special variables."
+  (assert (good-muffed-var-name-p name) (name)
+          "Special variable ~s is not wearing earmuffs :(")
+  `(progn
+     (defvar ,name)
+     ,@(when initp
+         (list `(setf ,name ,init)))
+     ,@(when doc
+         (list `(setf (documentation ',name 'cl:variable) ,doc)))))
+
+(defmacro const (name value &optional doc)
+  "Define a constant in a way that is redefinable whenever the form is
+reevaluated."
+  (assert (good-muffed-var-name-p name :muffer "+"))
+  `(progn
+     (handler-bind ((error
+                      (lambda (&rest ignore)
+                        (declare (ignore ignore))
+                        (invoke-restart 'cl:continue))))
+       (makunbound ',name))
+     (defconstant ,name ,value ,@(when doc (list doc)))))
+
+(defmacro class (name (&rest supers) &body slots-and-options)
+  "Define a class. 
+
+SLOTS-AND-OPTIONS := (SLOT-SPEC1 ... SLOT-SPECN . CLASS-OPTIONS)
+
+Each SLOT-SPEC is a list of slot names followed by keyword slot
+options, E.g:
+
+(X Y Z :type real :initform 0)
+
+Would expand into three slot definitions 
+(X :accessor X :initarg :X :type real :initform 0)
+(Y :accessor Y :initarg :Y :type real :initform 0)
+(Z :accessor Z :initarg :Z :type real :initform 0)
+
+There are a few flag style slot definition arguments. Flags do not
+have an value after them, all flags must come before other options. Flags are:
+  :prefix - prefix the accessor by the class name
+  :ro     - only define a reader 
+  :wo     - only define a writer 
+
+By default an accessor is defined.
+
+CLASS-OPTIONS is a PLIST of class options.
+
+E.g.
+
+(def:class pt (thing)
+  (x y z :prefix :type real :initform 0) 
+  (label :type :string)
+"
+  (labels
+      ((make-accessor-name (slot &optional prefix?)
+         (if prefix?
+             (intern (format nil "~a-~a" name slot))
+             slot))
+       (singlep (x)
+         (find x '(:prefix :ro :wo) :test #'eq))
+       (parse-slot-spec-expr (expr)
+         " (names ... &key kwargs)"
+         (multiple-value-bind (slot-names kwargs) (take-until #'keywordp expr)
+           (multiple-value-bind (singles kwargs) (partition #'singlep kwargs)
+             (let ((prefix-accessor? (find ':prefix singles :test #'eq))
+                   (read-only? (find ':ro singles :test #'eq))
+                   (write-only? (find ':wo singles :test #'eq)))
+               (assert (not (and read-only? write-only?)) ()
+                       "A slot cannot be both read-only (:ro) and write-only (:wo).")
+               (loop
+                 :with accessor-type := (cond (read-only? :reader)
+                                              (write-only? :writer)
+                                              (t :accessor))
+                 :for slot :in slot-names
+                 :collect `(,slot
+                            ,accessor-type ,(make-accessor-name slot prefix-accessor?)
+                            :initarg ,(alexandria:make-keyword slot)
+                            ,@kwargs))))))
+
+       (parse-class-options (kwargs)
+         (loop :for (key val . more) :on kwargs :by #'cddr
+               :collect (list key val))))
+
+    (let* ((slot-defs (loop :for expr :in slots-and-options
+                            :while (listp expr)
+                            :append (parse-slot-spec-expr expr)))
+           (options (parse-class-options
+                     (nth-value 1 (take-until #'keywordp slots-and-options)))))
+
+      `(defclass ,name ,supers
+         (,@slot-defs)
+         ,@options))))
+
+
+
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..779ea68
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,6 @@
+;;;; package.lisp
+
+(defpackage #:def
+  (:use #:cl)
+  (:shadow #:var #:class)
+  (:export #:class #:var #:const))
diff --git a/util.lisp b/util.lisp
new file mode 100644
index 0000000..537d85d
--- /dev/null
+++ b/util.lisp
@@ -0,0 +1,36 @@
+(in-package #:def)
+
+
+(defun take-until (pred list)
+  "Returns two values: FRONT BACK.
+
+FRONT contains the first N members X of LIST for which (PRED X) is NIL.
+BACK contains everything after the members of FRONT.
+
+(EQUALP LIST
+       (MULTIPLE-VALUE-BIND (FRONT BACK) (TAKE-UNTIL PRED LIST)
+           (APPEND FRONT BACK))
+
+Is always T."
+  (loop :for (x . back) :on list
+        :for fx? := (funcall pred x)
+        :until fx?
+        :collect x :into front
+        :finally (return (values front (if fx? (cons x back) nil)))))
+
+(defun partition (pred list)
+  "Returns two list values: YES NO.
+
+YES is everything for which PRED is T, NO is everything else."
+  (loop :for e :in list
+        :when (funcall pred e)
+          :collect e :into yes
+        :else
+          :collect e :into no
+        :finally (return (values yes no))))
+
+(defun good-muffed-var-name-p (name &key (muffer "*"))
+  (and (symbolp name)
+       (string= muffer name :end2 (length muffer))
+       (string= muffer name :start2 (- (length (symbol-name name))
+                                       (length muffer)))))