;;;; 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))))