;;;; cl-scopes/core - here comes the real action

(defpackage :scopes/core
  (:use :common-lisp)
  (:local-nicknames (:config :scopes/config)
                    (:message :scopes/core/message))
  (:export #:root-config #:add-config #:add-action
           #:default-setup #:setup-services
           #:context #:*root* #:find-service #:config #:name #:send
           #:printer))

(in-package :scopes/core)

;;;; config

(defclass config (config:root) ())

(defun root-config (&rest params)
  (apply #'make-instance 'config params))

(defclass service-config (config:base)
  ((name :reader name :initarg :name)
   (setup :reader setup :initarg :setup :initform #'default-setup)
   (actions :accessor actions :initarg :actions :initform nil)))

(defun add-config (parent name &rest params
                   &key (setup #'default-setup) (class 'service-config)
                   &allow-other-keys)
  (apply #'make-instance class :parent parent :name name :setup setup params))

(defgeneric add-action (container pattern handler)
  (:method ((cfg service-config) pattern handler)
    (push (list pattern handler) (actions cfg))))

;;;; actions

(defclass action-spec ()
  ((pattern :reader pattern :initarg :pattern :initform nil)
   (handlers :reader handlers :initarg :handlers)))

(defun select (msg acts)
  (let ((h (message:head-as-list msg))
        (hdlrs nil))
    (dolist (a acts)
      (if (match (pattern a) h)
        (dolist (hdlr (handlers a))
          (push hdlr hdlrs))))
    hdlrs))
    ;(nreverse hdlrs)))

(defun match (pat h)
  (dolist (item pat)
    (if (and item (not (eq item (pop h))))
      (return-from match nil)))
  t)

(defun find-action (pat acts)
  (dolist (a acts)
    (if (equal (pattern a) pat)
      (return-from find-action a))))

;;;; context

(defvar *root* nil)

(defclass context () 
   ((config :reader config :initarg :config)
    (name :reader name :initarg :name)
    (actions :accessor actions :initform nil)
    (services :initform (make-hash-table))))

(defun default-setup (cfg &optional (cls 'context))
  (make-instance cls :config cfg :name (name cfg)))

(defun find-service (name)
  (with-slots (services) *root*
    (when services
      (gethash name services))))

(defun setup-services (cfg)
  (setf *root* (make-instance 'context :config cfg))
  (dolist (c (config:children cfg))
    (add-service *root* c)))

(defmethod add-action ((ctx context) pat hdlr)
  (let* ((acts (actions ctx))
         (act (find-action pat acts)))
    (if act
      (push hdlr (handlers act))
      (push (make-instance 'action-spec :pattern pat :handlers (list hdlr)) 
            (actions ctx)))))

(defun add-service (ctx cfg)
  (with-slots (services) ctx
    (let ((child (funcall (setup cfg) cfg)))
      (dolist (a (actions cfg))
        (add-action child (car a) (cadr a)))
      (setf (gethash (name cfg) services) child))))

(defgeneric send (rcvr msg)
  (:method ((rcvr context) msg)
    (let* ((acts (actions rcvr))
           (hdlrs (select msg acts)))
      (if hdlrs
        (dolist (hdlr hdlrs)
          (funcall hdlr rcvr msg))
        (log:warn "no action selected for ~s" msg)))))

;;;; simple printer service

(defun do-print (ctx msg)
  (declare (ignore ctx))
  (format t "~&~s~%" msg))

(defclass printer (context)
  ((actions :initform 
            (list (make-instance 'action-spec 
                                 :handlers (list #'do-print))))))

(defun printer (name)
  (make-instance 'printer :name name))