Clean up eval-tree

6 files changed, 146 insertions, 84 deletions

diff --git a/src/core.lisp b/src/core.lisp
index 1a1a3b8..87d9755 100644
--- a/src/core.lisp
+++ b/src/core.lisp
@@ -70,10 +70,12 @@
   (setf arglist (mapcar #'object-value arglist))
   (let ((env environment))
     (make-closure  #'(lambda (environment siblings &rest args)
-                       (tree-eval (append (pairlis arglist args)
-                                          env
-                                          environment)
-                                  body))
+                       ;; Splice arguments into resulting link
+                       (flatten
+                        (eval-tree (append (pairlis arglist args)
+                                           env
+                                           environment)
+                                   body)))
                    arglist (complement #'identity) env :function)))
 
 (define-special lambda* (arglist group-predicate body)
@@ -83,7 +85,7 @@
 
   (cond ((and (listp group-predicate))
          ;; TODO: Check arglist of predicate
-         (setf group-predicate (first (tree-eval environment group-predicate)))
+         (setf group-predicate (first (eval-tree environment group-predicate)))
 
          (assert (closurep group-predicate))
          (let ((function (closure-function group-predicate)))
@@ -94,7 +96,7 @@
 
   (let ((env environment))
     (make-closure  #'(lambda (environment siblings &rest args)
-                       (tree-eval (append (pairlis arglist args)
+                       (eval-tree (append (pairlis arglist args)
                                           (list (cons (intern "SIBLINGS" *interpreter-package*)
                                                       siblings))
                                           env
@@ -121,24 +123,24 @@ respectives values"
          body)))
 
 ;; Is this basically quasiquote?
-(define-special syntax (arglist body)
-  (setf arglist (remove-if #'whitespace-text-p arglist))
-  (assert (every #'object-symbol-p arglist))
-  (setf arglist (mapcar #'object-value arglist))
-  (make-closure  #'(lambda (environment siblings &rest args)
-                     (declare (ignorable environment siblings))
-                     (syntax-expand (pairlis arglist args) body))
-                 arglist (complement #'identity) environment :syntax))
-
+;; (define-special syntax (arglist body)
+;;   (setf arglist (remove-if #'whitespace-text-p arglist))
+;;   (assert (every #'object-symbol-p arglist))
+;;   (setf arglist (mapcar #'object-value arglist))
+;;   (make-closure  #'(lambda (environment siblings &rest args)
+;;                      (declare (ignorable environment siblings))
+;;                      (syntax-expand (pairlis arglist args) body))
+;;                  arglist (complement #'identity) environment :syntax))
+
+;;; TODO: require single element list
 (define-special* define (name value) (siblings #'identity)
   (assert (object-symbol-p (first name)))
   (setf name (object-value (first name)))
-  (setf value (first (tree-eval environment value)))
-  (tree-eval (acons name value environment)
+  (setf value (first (eval-tree environment value)))
+  (eval-tree (acons name value environment)
              siblings))
 
-;; TODO: Restrict chain link's length to avoid so many asserts
-
+;;; TODO: Restrict chain link's length to avoid so many asserts
 (define-function gp (symbol)
   (assert (object-symbol-p (first symbol)) nil "a")
   (setf symbol (first symbol))
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)))
diff --git a/src/interpreter.lisp b/src/interpreter.lisp
index e69de29..6c47d4b 100644
--- a/src/interpreter.lisp
+++ b/src/interpreter.lisp
@@ -0,0 +1,43 @@
+(use-package :chains)
+
+(alexandria:define-constant +command-line-options+
+    '((:help #\h)
+      (:help "help")
+      (:use #\u :required)
+      (:use "use" :required)
+      (:use #\i :required)
+      (:use "include" :required))
+  :test #'equal
+  :documentation "")
+
+(defun help ()
+  (format t "~&Usage: chains [OPTION]... FILE...
+
+  -i, --include
+  -u, --use
+  -h, --help
+"))
+
+(defun parse-arguments (command-line-arguments)
+  (multiple-value-bind (options others unknowns)
+      (just-getopt-parser:getopt command-line-arguments +command-line-options+)
+    (cond ((assoc :help options)
+           (help)
+           (sb-posix:exit 0))
+          (unknowns
+           (help)
+           (sb-posix:exit 1))
+          (t
+           (loop :for (option . value) :in options :do
+             (case option
+               ))))
+    others))
+
+(defun chains ()
+  (let ((files (parse-arguments (uiop:command-line-arguments))))
+    (dolist (file files)
+      (with-open-file (stream file :direction :input)
+        (mapc (alexandria:compose #'princ #'chains::content)
+              (alexandria:flatten (chains:eval-tree chains:*default-environment*
+                                                    (chains:build-tree
+                                                     (chains:read-tokens stream)))))))))
diff --git a/src/package.lisp b/src/package.lisp
index 962ce17..ee9b664 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -3,7 +3,10 @@
         #:split-sequence
         #:alexandria
         #:trivia)
-  (:export))
+  (:export #:eval-tree
+           #:*default-environment*
+           #:build-tree
+           #:read-tokens))
 
 (in-package #:chains)
 
diff --git a/src/parser.lisp b/src/parser.lisp
index f0821fc..2d3c673 100644
--- a/src/parser.lisp
+++ b/src/parser.lisp
@@ -1,11 +1,14 @@
 (in-package #:chains)
 
-(defconstant +special-characters+
-  '(#\\ #\% #\@ #\$ #\{ #\} #\[ #\] #\Newline)
-  "")
+(define-constant +special-characters+
+    '(#\\ #\% #\@ #\$ #\{ #\} #\[ #\] #\Newline)
+  :test #'equal
+  :documentation  "")
 
-(defconstant +whitespace+ '(#\Tab #\Newline #\Return #\Space)
-  "")
+(define-constant +whitespace+
+    '(#\Tab #\Newline #\Return #\Space)
+  :test #'equal
+  :documentation "")
 
 ;; TODO: (read-char stream nil)
 (defun read-if (predicate stream)
@@ -101,7 +104,7 @@ tokens."
              (multiple-value-bind (tree rest) (build-tree tail)
                (values tree rest)))
             ;; @a{...} <-> {@a}{...}
-            ((and (object-symbolp head)
+            ((and (object-symbol-p head)
                   (eq (first tail) 'link-start))
              (multiple-value-bind (links rest) (build-chain (rest tail))
                (multiple-value-bind (tree rest) (build-tree rest)
@@ -133,7 +136,7 @@ tokens."
       (and (textp last-token)
            (newlinep (last-elt (content last-token))))))
 
-(defun read-tree (stream)
+(defun read-tokens (stream)
   "Build a syntax tree from the contents of STREAM"
   (loop :with start-of-line = t
         :for token = (next-token stream start-of-line)
diff --git a/src/types.lisp b/src/types.lisp
index c845b2d..4b24219 100644
--- a/src/types.lisp
+++ b/src/types.lisp
@@ -19,6 +19,9 @@
 (defmethod content ((object (eql 'empty-line)))
   (list (make-text "")))
 
+(defmethod print-object ((object text) stream)
+  (format stream "#<TEXT \"~A\">" (content object)))
+
 (defclass closure ()
   ((function :reader closure-function
              :initarg :function
@@ -50,21 +53,6 @@
 (defun closurep (object)
   (typep object 'closure))
 
-(defun group (item sequence &key (test #'eql))
-  (group-if #'(lambda (x) (funcall test item x)) sequence))
-
-(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-if-not (predicate sequence)
-  (group-if (complement predicate) sequence))
-
 (defun whitespacep (char-or-string)
   (if (stringp char-or-string)
       (every #'whitespacep char-or-string)
@@ -104,6 +92,9 @@
 (defun object-symbol-p (object)
   (and (objectp object) (eq (object-type object) :symbol)))
 
+(deftype object-symbol ()
+  `(satisfies object-symbol-p))
+
 (defmethod print-object ((object object) stream)
   (format stream "#<OBJECT :TYPE ~A :VALUE ~A>"
           (object-type object) (object-value object)))