Clean up eval-tree

1 files changed, 62 insertions, 42 deletions

diff --git a/src/eval.lisp b/src/eval.lisp
index e3e6617..b2c399c 100644
--- a/src/eval.lisp
+++ b/src/eval.lisp
@@ -1,44 +1,64 @@
 (in-package #:chains)
 
-(defun tree-eval (environment node)
-  (cond ((null node)
-         nil)
-        ((object-symbol-p node)
-         (get-var environment (object-value node)))
-        ((not (consp node))
-         node)
-        ((chainp (first node))
-         (destructuring-bind (flink &rest rlinks) (chain-links (first node))
-           (setf flink (tree-eval environment flink))
-           (assert (and (consp flink)
-                        (closurep (first flink))
-                        (null (rest flink)))
-                   (flink)
-                   "1~A ~A" flink (content (second flink)))
-           (let* ((closure (first flink))
-                  (function (closure-function closure))
-                  (group-predicate (closure-group-p closure)))
-             (multiple-value-bind (siblings rest)
-                 (group-if group-predicate (rest node))
-               (append
-                ;; Evaluating a function returns a sublink, flatten all sublink
-                (flatten
-                 (let ((eval-with-environment (curry #'tree-eval environment)))
-                   (case (closure-type closure)
-                     (:syntax
-                      (let ((body (ensure-list (apply function environment siblings rlinks)))
-                            (ret nil))
-                        ;; (format t "~&Body: ~A~%" body)
-                        (setf ret (tree-eval environment (append body (rest node))))
-                        (setf rest nil)
-                        ret))
-                     (:special
-                      (ensure-list (apply function environment siblings rlinks)))
-                     (:function
-                      (let ((args (mapcar eval-with-environment rlinks))
-                            (siblings (funcall eval-with-environment siblings)))
-                        (ensure-list (apply function environment siblings args)))))))
-                (tree-eval environment rest))))))
-        (t
-         (cons (tree-eval environment (first node))
-               (tree-eval environment (rest node))))))
+(defun group-if (predicate sequence)
+  (loop :for (head . tail) :on sequence
+        :while (funcall predicate head)
+        :collect head :into group
+        :finally
+           (return (values group (if (not (funcall predicate head))
+                                     (cons head tail)
+                                     tail)))))
+
+(defun group (item sequence &key (test #'eql))
+  (group-if #'(lambda (x) (funcall test item x)) sequence))
+
+(defun group-if-not (predicate sequence)
+  (group-if (complement predicate) sequence))
+
+(defun link-closure (link)
+  "Returns the function object inside the first link of a chain"
+  (setf link (remove-if #'whitespace-text-p link))
+  (assert (and (not (null link))
+               (closurep (first link))
+               (null (rest link)))
+          (link)
+          "Link is not callable: ~A" link)
+  (first link))
+
+(defun eval-chain (environment chain siblings)
+  "Evaluate CHAIN inside ENVIRONMENT and possibly consume SIBLINGS. Returns a
+link with the evaluated body of the function under the ENVIRONMENT"
+  (destructuring-bind (head &rest arguments)
+      (chain-links chain)
+    (with-accessors ((function closure-function)
+                     (type closure-type)
+                     (group-predicate closure-group-p))
+        ;; Evaluate all elements of first link and get closure object
+        (link-closure (eval-tree environment head))
+      (multiple-value-bind (consumed-siblings rest)
+          (group-if group-predicate siblings)
+        (values
+         (apply function
+                environment
+                consumed-siblings
+                (ecase type
+                  (:special
+                   arguments)
+                  (:function
+                   (mapcar (curry #'eval-tree environment) arguments))))
+         rest)))))
+
+(defun eval-tree (environment node)
+  (typecase node
+    (object-symbol
+     (get-var environment (object-value node)))
+    (cons
+     (destructuring-bind (head &rest tail)
+         node
+       (if (chainp head)
+           (multiple-value-bind (result rest)
+               (eval-chain environment head tail)
+             (append (ensure-list result) (eval-tree environment rest)))
+           (cons (eval-tree environment head) (eval-tree environment tail)))))
+    (t
+     node)))