(defpackage #:sarcasm.util
  (:use #:cl)
  (:export
   #:take-until
   #:def/class))

(in-package #:sarcasm.util)

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

(defmacro def/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 integer :initarg 0)

Would expand into three slot definitions 
(X :accessor X :initarg :X :type integer :initarg 0)
(Y :accessor Y :initarg :Y :type integer :initarg 0)
(Z :accessor Z :initarg :Z :type integer :initarg 0)

CLASS-OPTIONS is a PLIST of class options."
  (labels
      ((make-accessor-name (slot &optional prefix?)
         (if prefix?
             (intern (format nil "~a-~a" name slot))
             slot))
       (singlep (x)
         (find x '(:prefix) :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)
             (loop
               :with prefix-accessor? := (find ':prefix singles :test #'eq)
               :for slot :in slot-names
               :collect `(,slot
                          :accessor ,(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))))

;;; SINGLETON CLASSES

(defclass singleton (closer-mop:standard-class)
  ((instance :reader singleton-instance
             :initarg :instance
             :documentation "The instance of a singleton class."))
  (:documentation "Metaclass for singleton classes."))


(defmethod closer-mop:validate-superclass
    ((sub singleton) (sup closer-mop:standard-class))
  t)

(defmethod make-instance ((class singleton) &rest kwargs)
  (declare (ignorable kwargs))
  (if (slot-boundp class 'instance)
      (slot-value class 'instance)
      (setf (slot-value class 'instance) (call-next-method))))