(in-package #:fwoar.lisputils)

(defmacro with-accessors* ((&rest accessors) object &body body)
  `(with-accessors ,(ensure-mapping accessors) ,object
     ,@body))

(defmacro new (class &rest initializer-syms)
  (multiple-value-bind (required optional rest) (parse-ordinary-lambda-list initializer-syms)
    (when optional
      (error "new doesn't handle optional arguments"))
    (if rest
        `(make-instance ,class
                        ,@(mapcan (lambda (_1)
                                    (list (alexandria:make-keyword _1)
                                          _1))
                                  required)
                        ,(make-keyword rest) ,rest)
        `(make-instance ,class
                        ,@(mapcan (lambda (_1)
                                    (list (alexandria:make-keyword _1)
                                          _1))
                                  initializer-syms)))))

(defmacro defclass+ (name (&rest super) &body (direct-slots &rest options))
  (let* ((initargs (append (mapcan (lambda (class)
                                     (typecase class
                                       (cons (mapcar (lambda (it)
                                                       (list it nil))
                                                     (cadr class)))
                                       (t nil)))
                                   super)
                           (mapcan (lambda (slot)
                                     (alexandria:ensure-list
                                      (alexandria:when-let ((initarg (getf (cdr slot)
                                                                           :initarg)))
                                        (fw.lu:prog1-bind
                                            (it (list
                                                 (list (make-symbol (symbol-name initarg))
                                                       (eq :missing
                                                           (getf (cdr slot)
                                                                 :initform
                                                                 :missing)))))))))
                                   direct-slots))))
    (destructuring-bind (required optional)
        (loop for it in initargs
              if (second it) collect (first it) into required
                else collect (first it) into optional
              finally (return (list required
                                    optional)))
      (let ((passed-args (mapcar (lambda (it)
                                   (make-symbol (concatenate 'string
                                                             (symbol-name it)
                                                             "-P")))
                                 optional)))
        `(progn (defclass ,name
                    ,(mapcar (lambda (it)
                               (typecase it
                                 (cons (car it))
                                 (t it)))
                      super)
                  ,direct-slots
                  ,@options)
                (defun ,name (,@required ,@(when optional
                                             (list* '&optional
                                                    (mapcar (lambda (it it-p)
                                                              `(,it nil ,it-p))
                                                            optional
                                                            passed-args))))
                  (declare (optimize (speed 3) (debug 0)))
                  ,(if optional
                       (let ((heads (reverse (inits optional))))
                         `(cond ,@(mapcar (lambda (it it-p)
                                            `(,it-p (fw.lu:new ',name ,@required ,@it)))
                                          heads
                                          passed-args)
                                (t (fw.lu:new ',name ,@required))))
                       `(fw.lu:new ',name ,@required ,@optional))))))))

(defun-ct %constructor-name (class)
  (format nil "~a-~a" '#:make class))

(defmacro make-constructor (class &rest args)
  (destructuring-bind (class &optional (constructor-name (intern (%constructor-name class))))
      (ensure-list class)
    `(defgeneric ,constructor-name (,@args)
       (:method (,@args)
         (new ',class ,@args)))))

(defclass hashtable-slot-mixin ()
  ((%doc :reader hsm-doc :initarg :doc)))

(defmethod c2mop:slot-value-using-class :before (class (object hashtable-slot-mixin) slotd)
  (let ((slot-name (c2mop:slot-definition-name slotd)))
    (unless (or (eql slot-name '%doc)
                (c2mop:slot-boundp-using-class class object slotd))
      (let* ((doc (hsm-doc object))
             (doc-value (gethash (substitute #\_ #\-
                                             (string-downcase
                                              (symbol-name slot-name)))
                                 doc)))
        (setf (slot-value object slot-name) doc-value)))))