Commits

David Krentzlin committed ce704c7 Draft

first working version of commands

Comments (0)

Files changed (3)

mira.core/src/kernel.lisp

 (defgeneric apply-processors (kernel messages stop-processing)
   (:documentation "Apply all processors to the messages and generate answers if apropriate")
   (:method ((kernel <kernel>) messages stop-processing)
-    (labels((skip  (answer)
-              (when answer
-                (write-answer-to-channels kernel answer)
-                (return-from apply-processors))))
+    (labels ((skip (answers)
+	       (format t "Skipping messages ~%")
+	       (log5:log-for (debug mira.core.logging::kernel) "Skipping following messages")
+	       (when answers
+		 (dolist (answer (ensure-list answers))
+		   (write-answer-to-channels kernel answer)))
+		 (return-from apply-processors)))
       (log5:log-for (info kernel) "messages received ~A" messages)
       (dolist (message messages)
         (dolist (processor (generic-handlers kernel))

mira.core/src/processor.lisp

 (in-package :cl-user)
 (defpackage :mira.core.processor
   (:use :cl :cl-annot :mira.core.debug :mira.core.acl :mira.core.message)
-  (:export id documentation))
+  (:export id documentation command-environment-issuer command-environment-answer-fn command-environment-skip-fn command-environment-quit-fn command-environment-processor))
 
 (in-package :mira.core.processor)
 (annot:enable-annot-syntax)
 (defvar *command-acl* (make-instance '<acl>))
 @export
 (defvar *access-denied-message* "Heh, nice try. You are not allowed to do that, dude!")
-@export
-(defvar *current-answer-function* nil)
-@export
-(defvar *current-kernel* nil)
-@export
-(defvar *current-processor* nil)
 
 @export
 (defclass <command-collection> ()
    (commands     :documentation "Commands that are associated with this processor"
 		 :accessor commands
                  :initform (make-instance '<command-collection> :acl *command-acl*))))
+@export
+(defstruct command-environment issuer processor answer-fn skip-fn quit-fn)
+  
 
 @export
-(defun answer (&rest arguments)
-  (and *current-answer-function*
-       (apply #'*current-answer-function* arguments)))
+(defun cmd-answer (env &rest arguments)
+  (let ((answer-fn (command-environment-answer-fn env)))
+    (format t "Answerfn is ~A ~S~%" answer-fn arguments)
+    (apply answer-fn arguments)))
 
-
+(defun answer (message result &key (channels) (sender-id) (receiver (sender message))
+  (messages (mapcar
+	     (lambda (data)
+	       (make-instance '<message>
+			      :receiver receiver
+			      :data data
+			      :sender-identity sender-id
+			      :generator-id (slot-value message 'mira.core.message::generator-id)
+			      :tag (tag message))
+	       (if (listp result) result (list result)))))))
+    
 @export
 (defgeneric process-message (processor message skip-following quit))
 
+(defun make-answer-function (message skip)
+  (lambda (result &key (channels) (sender-id) (receiver (sender message)))
+    (let ((messages (mapcar
+		     (lambda (data)
+		       (make-instance '<message>
+				      :receiver receiver
+				      :data data
+				      :sender-identity sender-id
+				      :generator-id (slot-value message 'mira.core.message::generator-id)
+				      :tag (tag message)))
+		       (if (listp result) result (list result)))))
+      (funcall skip messages))))
+
 (defmethod  process-message ((processor <commands-mixin>) (message <message>) skip-following quit)
   (let* ((ident (sender-identity message))
 	 (input (data message))
 	 (self  (string-downcase (self processor)))
 	 (prefix (prefix processor))
 	 (commands (commands processor))
-	 (*current-processor* processor)
-	 (*current-kernel* (slot-value processor 'kernel))
-	 (*current-answer-function*
-	  (lambda (result &key (channels) (sender-id) (receiver (sender message)))
-	    (format t "Answering with ~A~%" result)
-	    (let ((messages (mapcar 
-			     (lambda (data)
-			       (make-instance '<message>
-					      :receiver receiver
-					      :data data
-					      :sender-identity sender-id
-					      :generator-id (slot-value message 'mira.core.message::generator-id)
-					      :tag (tag message))
-			       (if (listp result) result (list result))))))
-		
-	      (funcall
-	       #'skip-following
-	       messages)))))
-    
+	 (command-env (make-command-environment :issuer ident 
+						:processor processor 
+						:answer-fn (make-answer-function message skip-following) 
+						:skip-fn skip-following 
+						:quit-fn quit)))
     (when (command-syntax? input prefix)
-      (format t "Have command syantx ~A with self ~A~%" input self)
       (multiple-value-bind (command arguments) (destructure-command input prefix)
-	(format t "Have destructured ~%")
 	(let ((cmd (find-command command commands ident)))
-	  (format t "Have found the command ~%")
 	  (case cmd
-	    ((:access-denied) (answer *access-denied-message*))
+	    ((:access-denied) (cmd-answer command-env *access-denied-message*))
 	    ((nil) nil)
-	    (t (apply-command cmd arguments message quit skip-following))))))))
+	    (t (apply-command cmd arguments command-env))))))))
 
-(defgeneric apply-command (command argument-string message quit skip)
+(defgeneric apply-command (command argument-string command-env)
   (:documentation "Applies the command to the given input")
-  (:method ((command <command>) arguments (message <message>) quit skip)
-
+  (:method ((command <command>) arguments command-env)
     (let ((argument-list (argument-string->argument-list arguments))
-          (cmd-closure (body command)))
+          (cmd-closure   (body command)))
       (if (equal (string-downcase (car argument-list)) "help")
-          (answer (help command))
-          (handler-case 
-	      (progn
-		(format t "Applying command to ~A~%" argument-list)
-		(apply cmd-closure argument-list))
-            (error ()
-	      (format t "Have an error ~A ~%" (usage command))
-              (answer (usage command))))))))
+          (cmd-answer command-env (help command))
+	  (apply cmd-closure (cons command-env argument-list))
+          ;; (handler-case 
+	  ;;     (progn
+	  ;; 	(format t "Applying command to ~A~%" argument-list)
+	  ;; 	(apply cmd-closure argument-list))
+          ;;   (error ()
+	  ;;     (format t "Have an error ~A ~%" (usage command))
+          ;;     (answer (usage command))))
+	  ))))
 
 (defmethod print-object ((object <processor>) stream)
   (print-unreadable-object (object stream :type t)

mira.processors/src/echo.lisp

   (call-next-method)
   (let ((content (mira.core.message:data message)))
     (answer
+     message
      (format nil "You said: ~A" content)
      :channels (list "stdio")
      :sender-id 'stdin)))