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

(defpackage :scopes/core
  (:use :common-lisp)
  (:local-nicknames (:config :scopes/config)
                    (:message :scopes/core/message)
                    (:shape :scopes/shape)
                    (:util :scopes/util)
                    (:alx :alexandria))
  (:export #:*root* #:default-setup #:default-actions 
           #:find-service #:setup-services
           #:context #:add-action #:config #:name #:send #:shutdown
           #:handle-message
           #:do-print #:echo))

(in-package :scopes/core)

;;;; actions

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

(defun select (msg acts)
  (let ((h (shape:head 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 base-context ()
  ())

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

(defun default-setup (cfg &optional (cls 'context) &rest args &key &allow-other-keys)
  (apply #'make-instance cls :config cfg :name (config:name cfg) args))

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

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

(defun shutdown ()
  (dolist (ctx (alx:hash-table-values (services *root*)))
    (funcall (config:shutdown (config ctx)) ctx)))

(defun add-action (ctx 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 (config:setup cfg) cfg)))
      (when child
        (dolist (a (config:actions cfg))
          (add-action child (car a) (cadr a)))
        (setf (gethash (config:name cfg) services) child)))))

(defgeneric send (rcvr msg)
  (:method ((rcvr context) msg)
    (handle-message rcvr msg)))

(defgeneric handle-message (ctx msg)
  (:method ((ctx context) msg)
    (cond 
      ((do-actions ctx msg) t)
      ((do-actions ctx msg #'default-actions) t)
      (t (util:lgw "no action selected" msg)))))

(defun do-actions (ctx msg &optional (acts #'actions))
  (let ((hdlrs (select msg (funcall acts ctx))))
    (when hdlrs
      (dolist (hdlr hdlrs)
        (funcall hdlr ctx msg))
      t)))

;;;; some simple predefined actions

(defun echo (ctx msg)
  (let ((sndr (message:sender msg)))
    (if sndr
      (let* ((h (shape:head msg))
             (new-msg (message:create `(:scopes :echo ,@(cddr h))
                                      :data (shape:data msg))))
        (send sndr new-msg))
      (util:lgw "sender missing" msg))))

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