(in-package :contextl)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun check-op/layer (op layer-name)
    (unless (member op '(+ -) :test #'eq)
      (error "Incorrect activation operator ~S. Must be + or -." op))
    (unless (symbolp layer-name)
      (error "Not a layer name: ~S." layer-name))
    (when (eq layer-name 't)
      (case op
        (+ (error "The root layer cannot be placed in front of other layers."))
        (- (error "The root layer must always be active."))))))

(defclass standard-layer-object (special-object)
  ())

(defclass standard-layer-class (special-class singleton-class)
  ((layer-name :initarg original-name
               :reader %layer-name)))

(defmethod validate-superclass
           ((class standard-layer-class)
            (superclass standard-class))
  t)

(defmethod initialize-instance :around
  ((class standard-layer-class) &rest initargs &key direct-superclasses)
  (declare (dynamic-extent initargs))
  (if (loop for direct-superclass in direct-superclasses
            thereis (subtypep direct-superclass (load-time-value (find-class 'standard-layer-object))))
    (call-next-method)
    (apply #'call-next-method
           class
           :direct-superclasses
           (append direct-superclasses
                   (load-time-value (list (find-class 'standard-layer-object))))
           initargs)))

(defmethod reinitialize-instance :around
  ((class standard-layer-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
  (declare (dynamic-extent initargs))
  (if (or (not direct-superclasses-p)
          (loop for direct-superclass in direct-superclasses
                thereis (subtypep direct-superclass (load-time-value (find-class 'standard-layer-object)))))
    (call-next-method)
    (apply #'call-next-method
           class
           :direct-superclasses
           (append direct-superclasses
                   (load-time-value (list (find-class 'standard-layer-object))))
           initargs)))

(defclass layer-direct-slot-definition (singleton-direct-slot-definition
                                        special-direct-slot-definition)
  ())

(defmethod direct-slot-definition-class ((class standard-layer-class) &key &allow-other-keys)
  (find-class 'layer-direct-slot-definition))

(defmacro deflayer (&whole form name &optional superlayers &body options)
  (when (assoc :metaclass options)
    (error "DEFLAYER does not support the :metaclass option in ~S. Use :layer-class instead." form))
  `(defclass ,(defining-layer name) ,(mapcar #'defining-layer superlayers)
     ,@(if options
         (loop for option in options
               if (eq (car option) :layer-class)
               collect `(:metaclass ,@(cdr option))
               else collect option)
         '(()))
     ,@(unless (assoc :layer-class options)
         '((:metaclass standard-layer-class)))
     (original-name ,name)))

(defgeneric layer-name (layer)
  (:method ((layer symbol)) layer)
  (:method ((layer standard-layer-object)) (layer-name (class-of layer)))
  (:method ((layer standard-layer-class)) (car (%layer-name layer))))

(defgeneric find-layer-class (layer &optional errorp environment)
  (:method ((layer symbol) &optional (errorp t) environment)
   (or (find-class (defining-layer layer) nil environment)
       (when errorp
         (error "There is no layer named ~S." layer))))
  (:method ((layer standard-layer-object) &optional errorp environment)
   (declare (ignore errorp environment))
   (class-of layer))
  (:method ((layer standard-layer-class) &optional errorp environment)
   (declare (ignore errorp environment))
   layer))

(defgeneric find-layer (layer &optional errorp)
  (:method ((layer symbol) &optional (errorp t))
   (let ((layer-class (find-layer-class layer errorp)))
     (when layer-class
       #-lispworks (ensure-finalized layer-class)
       (class-prototype layer-class))))
  (:method ((layer standard-layer-object) &optional errorp)
   (declare (ignore errorp))
   layer)
  (:method ((layer standard-layer-class) &optional errorp)
   (declare (ignore errorp))
   #-lispworks (ensure-finalized layer)
   (class-prototype layer)))

(defgeneric layer-makunbound (layer)
  (:method ((layer symbol))
   (setf (find-class (defining-layer layer)) nil))
  (:method ((layer standard-layer-object))
   (setf (find-class (class-name (class-of layer))) nil))
  (:method ((layer standard-layer-class))
   (setf (find-class (class-name layer)) nil)))

(defclass root-specializer () ()
  (:metaclass standard-layer-class))
(ensure-finalized (find-class 'root-specializer))

(defstruct layer-context
  (prototype (class-prototype (find-class 'root-specializer))
             :type standard-object
             :read-only t)
  (specializer (find-class 'root-specializer)
               :type standard-layer-class
               :read-only t)
  (children/ensure-active () :type list)
  (children/ensure-inactive () :type list))

#-allegro
(declaim (type layer-context *root-context* *active-context*))
#+allegro
(eval-when (:load-toplevel :execute)
  (proclaim '(type layer-context *root-context* *active-context*)))

(defparameter *root-context* (make-layer-context))

(defparameter *active-context* *root-context*)

(defun layer-active-p (layer &optional (context *active-context*))
  (subtypep (layer-context-specializer context)
            (find-layer-class layer)))

(define-layered-function activate-layer-using-class (layer-class active-context)
  (:method ((layer-class standard-layer-class) active-context)
   (let ((active-context-specializer (layer-context-specializer active-context)))
     (values
      (if (subtypep active-context-specializer layer-class)
        active-context
        (let ((new-specializer
	       (ensure-finalized
		(make-instance 'standard-layer-class
			       :direct-superclasses
			       (list layer-class active-context-specializer)))))
          (make-layer-context
           :prototype (class-prototype new-specializer)
           :specializer new-specializer)))
      t))))

(defun activate-layer (layer active-context)
  (multiple-value-bind
      (new-layer-context cacheablep)
      (activate-layer-using-class (find-layer-class layer) active-context)
    (if cacheablep
      (setf (getf (layer-context-children/ensure-active active-context) layer)
            new-layer-context)
      new-layer-context)))

(declaim (inline ensure-active-layer-context))

(defun ensure-active-layer-context (layer active-context)
  (declare (optimize (speed 3) (debug 0) (safety 0)
                     (compilation-speed 0)))
  (or (getf (layer-context-children/ensure-active active-context) layer)
      (activate-layer layer active-context)))

(defun ensure-active-layer (layer-name)
  (check-op/layer '+ layer-name)
  (setf *active-context*
        (locally
          (declare (optimize (speed 3) (debug 0) (safety 0)
                             (compilation-speed 0)))
          (ensure-active-layer-context layer-name *active-context*))))

(define-layered-function deactivate-layer-using-class (layer-class active-context)
  (:method ((layer-class standard-layer-class) active-context)
   (let ((active-context-specializer (layer-context-specializer active-context)))
     (values
      (loop for context-specializer = active-context-specializer
            then (second (class-direct-superclasses context-specializer))
            for active-layers = (list (first (class-direct-superclasses context-specializer)))
            then (cons (first (class-direct-superclasses context-specializer)) active-layers)
            until (eq context-specializer (load-time-value (find-class 'root-specializer)))
            finally
            (return (loop for new-layer-context = *root-context*
                          then (if (subtypep active-layer layer-class)
                                 new-layer-context
                                 (ensure-active-layer-context (layer-name active-layer) new-layer-context))
                          for active-layer in (cdr active-layers)
                          finally (return new-layer-context))))
      t))))

(defun deactivate-layer (layer active-context)
  (multiple-value-bind
      (new-layer-context cacheablep)
      (deactivate-layer-using-class (find-layer-class layer) active-context)
    (if cacheablep
      (setf (getf (layer-context-children/ensure-inactive active-context) layer)
            new-layer-context)
      new-layer-context)))

(declaim (inline ensure-inactive-layer-context))

(defun ensure-inactive-layer-context (layer active-context)
  (declare (optimize (speed 3) (debug 0) (safety 0)
                     (compilation-speed 0)))
  (or (getf (layer-context-children/ensure-inactive active-context) layer)
      (deactivate-layer layer active-context)))

(defun ensure-inactive-layer (layer-name)
  (check-op/layer '- layer-name)
  (setf *active-context*
        (locally
          (declare (optimize (speed 3) (debug 0) (safety 0)
                             (compilation-speed 0)))
          (ensure-inactive-layer-context layer-name *active-context*))))

(defmacro with-active-layer (layer-name &body body)
  (check-op/layer '+ layer-name)
  `(let ((*active-context*
          (locally
            (declare (optimize (speed 3) (debug 0) (safety 0)
                               (compilation-speed 0)))
            (ensure-active-layer-context ',layer-name *active-context*))))
     ,@body))

(defmacro with-active-layers ((&rest layer-names) &body body)
  (if (every #'symbolp layer-names)
    (if layer-names
      `(with-active-layer ,(car layer-names)
         (with-active-layers ,(cdr layer-names)
           ,@body))
      `(progn ,@body))
    (loop for form = `(with-special-initargs ,(loop for layer-spec in layer-names
                                                    when (consp layer-spec)
                                                    collect `((find-layer ',(car layer-spec)) ,@(cdr layer-spec)))
                        ,@body)
          then `(with-active-layer ,layer-name ,form)
          for layer-spec in (reverse layer-names)
          for layer-name = (if (symbolp layer-spec)
                             layer-spec
                             (car layer-spec))
          finally (return form))))

(defmacro with-active-layers* ((&rest layer-names) &body body)
  (if (every #'symbolp layer-names)
    (if layer-names
      `(with-active-layer ,(car layer-names)
         (with-active-layers ,(cdr layer-names)
           ,@body))
      `(progn ,@body))
    (loop for form = `(with-special-initargs* ,(loop for layer-spec in layer-names
                                                     when (consp layer-spec)
                                                     collect `((find-layer ',(car layer-spec)) ,@(cdr layer-spec)))
                        ,@body)
          then `(with-active-layer ,layer-name ,form)
          for layer-spec in (reverse layer-names)
          for layer-name = (if (symbolp layer-spec)
                             layer-spec
                             (car layer-spec))
          finally (return form))))

(defmacro with-inactive-layer (layer-name &body body)
  (check-op/layer '- layer-name)
  `(let ((*active-context*
          (locally
            (declare (optimize (speed 3) (debug 0) (safety 0)
                               (compilation-speed 0)))
            (ensure-inactive-layer-context ',layer-name *active-context*))))
     ,@body))

(defmacro with-inactive-layers ((&rest layer-names) &body body)
  (if layer-names
    `(with-inactive-layer ,(car layer-names)
       (with-inactive-layers ,(cdr layer-names)
         ,@body))
    `(progn ,@body)))

(defun funcall-with-layer (op layer function &rest args)
  (declare (dynamic-extent args))
  (check-op/layer op layer)
  (let ((*active-context*
         (locally
           (declare (optimize (speed 3) (debug 0) (safety 0)
                              (compilation-speed 0)))
           (ecase op
             (+ (ensure-active-layer-context layer *active-context*))
             (- (ensure-inactive-layer-context layer *active-context*))))))
    (apply function args)))

(define-compiler-macro funcall-with-layer (&whole form op layer function &rest args)
  (if (and (consp op) (eq (car op) 'quote)
           (consp layer) (eq (car layer) 'quote))
    (let ((evop (eval op))
          (evlayer (eval layer)))
      (check-op/layer evop evlayer)
      (ecase evop
        (+ `(with-active-layer ,evlayer
              (funcall ,function ,@args)))
        (- `(with-inactive-layer ,evlayer
              (funcall ,function ,@args)))))
    form))

(defun funcall-with-layers (layers function &rest args)
  (declare (dynamic-extent args))
  (if layers
    (funcall-with-layer
     (car layers)
     (cadr layers)
     (lambda ()
       (apply #'funcall-with-layers (cddr layers) function args)))
    (apply function args)))

(define-compiler-macro funcall-with-layers (&whole form layers function &rest args)
  (cond ((null layers) `(funcall ,function ,@args))
        ((and (consp layers) (eq (car layers) 'quote))
         (let ((evlayers (eval layers)))
           (unless (listp evlayers)
             (error "Incorrect layers argument to funcall-with-layers: ~S." layers))
           (if (null evlayers)
             `(funcall ,function ,@args)
             (progn
               (check-op/layer (car evlayers) (cadr evlayers))
               (ecase (car evlayers)
                 (+ `(with-active-layer ,(cadr evlayers)
                       (funcall-with-layers ',(cddr evlayers) ,function ,@args)))
                 (- `(with-inactive-layer ,(cadr evlayers)
                       (funcall-with-layers ',(cddr evlayers) ,function ,@args))))))))
        (t form)))

(defun apply-with-layer (op layer function &rest args)
  (declare (dynamic-extent args))
  (check-op/layer op layer)
  (let ((*active-context*
         (locally
           (declare (optimize (speed 3) (debug 0) (safety 0)
                              (compilation-speed 0)))
           (ecase op
             (+ (ensure-active-layer-context layer *active-context*))
             (- (ensure-inactive-layer-context layer *active-context*))))))
    (apply #'apply function args)))

(define-compiler-macro apply-with-layer (&whole form op layer function &rest args)
  (if (and (consp op) (eq (car op) 'quote)
           (consp layer) (eq (car layer) 'quote))
    (let ((evop (eval op))
          (evlayer (eval layer)))
      (check-op/layer evop evlayer)
      (ecase evop
        (+ `(with-active-layer ,evlayer
              (apply ,function ,@args)))
        (- `(with-inactive-layer ,evlayer
              (apply ,function ,@args)))))
    form))

(defun apply-with-layers (layers function &rest args)
  (declare (dynamic-extent args))
  (if layers
    (funcall-with-layer
     (car layers)
     (cadr layers)
     (lambda ()
       (apply #'apply-with-layers (cddr layers) function args)))
    (apply #'apply function args)))

(define-compiler-macro apply-with-layers (&whole form layers function &rest args)
  (cond ((null layers) `(apply ,function ,@args))
        ((and (consp layers) (eq (car layers) 'quote))
         (let ((evlayers (eval layers)))
           (unless (listp evlayers)
             (error "Incorrect layers argument to apply-with-layers: ~S." layers))
           (if (null evlayers)
             `(apply ,function ,@args)
             (progn
               (check-op/layer (car evlayers) (cadr evlayers))
               (ecase (car evlayers)
                 (+ `(with-active-layer ,(cadr evlayers)
                       (apply-with-layers ',(cddr evlayers) ,function ,@args)))
                 (- `(with-inactive-layer ,(cadr evlayers)
                       (apply-with-layers ',(cddr evlayers) ,function ,@args))))))))
        (t form)))