+ Can now define functions.

% However, they currently access Clojure's environment, instead of the interpreter's.

6 files changed, 307 insertions, 64 deletions

diff --git a/src/example/test1.lang b/src/example/test1.lang
index f6f244a57..da3d3fa87 100644
--- a/src/example/test1.lang
+++ b/src/example/test1.lang
@@ -1,6 +1,9 @@
 
 (* 5 6)
 
-(defdata (List x)
-  (#Nil [])
-  (#Cons [x] (List x)))
+(def (repeat n val)
+  (if (<=' n 0)
+    (#Nil [])
+    (#Cons [val (repeat (-' n 1) val)])))
+
+(repeat 5 5)
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
new file mode 100644
index 000000000..21ef925b5
--- /dev/null
+++ b/src/lang/compiler.clj
@@ -0,0 +1,136 @@
+(ns lang.compiler
+  (:refer-clojure :exclude [compile])
+  (:require [clojure.core.match :refer [match]]
+            (lang [util :as &util :refer [exec return* return fail fail*
+                                          repeat-m try-m try-all-m map-m
+                                          apply-m]]
+                  [parser :as &parser]
+                  [lexer :as &lexer])
+            :reload))
+
+(declare compile-form)
+
+;; [Utils]
+(def ^:private +state+
+  {:globals {}
+   :stack {}
+   :forms '()})
+
+(defn wrap [x]
+  (update-in +state+ [:forms] conj x))
+
+(defn wrap* [env x]
+  (-> +state+
+      (update-in [:stack] merge env)
+      (update-in [:forms] conj x)))
+
+(defmacro ^:private defcompiler [name match return]
+  `(def ~name
+     (fn [state#]
+       (let [~'*token* (first (:forms state#))]
+         ;; (prn '~name ~'*token*)
+         (match ~'*token*
+           ~match
+           (let [output# (~return (update-in state# [:forms] rest))]
+             ;; (prn "output#" output#)
+             output#)
+           _#
+           (fail* (str "Unknown syntax: " (pr-str ~'*token*))))))))
+
+(defn unwrap-ident [ident]
+  (match ident
+    [::&parser/ident ?label]
+    ?label))
+
+(defn unwrap-tagged [ident]
+  (match ident
+    [::&parser/tagged ?tag ?data]
+    [?tag ?data]))
+
+(defcompiler compile-int
+  [::&parser/int ?int]
+  (return ?int))
+
+(defcompiler compile-ident
+  [::&parser/ident ?name]
+  (return (symbol ?name)))
+
+(defcompiler compile-tuple
+  [::&parser/tuple ?elems]
+  (exec [=elems (map-m (fn [elem] (apply-m compile-form (wrap elem)))
+                       ?elems)]
+    (return (vec =elems))))
+
+(defcompiler compile-tagged
+  [::&parser/tagged ?tag ?data]
+  (exec [=data (apply-m compile-form (wrap ?data))]
+    (return {:tag ?tag :data =data})))
+
+(defcompiler compile-fn-call
+  [::&parser/fn-call ?fn ?args]
+  (exec [=fn (apply-m compile-form (wrap ?fn))
+         =args (map-m (fn [arg] (apply-m compile-form (wrap arg)))
+                      ?args)]
+    (return (reduce (fn [f a] `(~f ~a))
+                    =fn =args))))
+
+(defcompiler compile-if
+  [::&parser/if ?test ?then ?else]
+  (exec [=test (apply-m compile-form (wrap ?test))
+         =then (apply-m compile-form (wrap ?then))
+         =else (apply-m compile-form (wrap ?else))]
+    (return `(if ~=test ~=then ~=else))))
+
+(defcompiler compile-def
+  [::&parser/def ?form ?body]
+  (match ?form
+    [::&parser/fn-call ?name ?args]
+    (exec [:let [=name (symbol (unwrap-ident ?name))
+                 =args (map (comp symbol unwrap-ident) ?args)
+                 fn-env (into {} (for [a =args] [a nil]))]
+           =body (apply-m compile-form (wrap* fn-env ?body))
+           :let [curled-body (reduce (fn [inner arg] `(fn [~arg] ~inner))
+                                     =body (reverse =args))
+                 ;; _ (prn 'curled-body curled-body)
+                 fn-def (let [[_ ?arg ?body] curled-body]
+                          `(fn ~=name ~?arg ~?body))
+                 ;; _ (prn 'fn-def fn-def)
+                 ]]
+      (return fn-def))))
+
+(defcompiler compile-defdata
+  [::&parser/defdata ?form ?cases]
+  (match ?form
+    [::&parser/fn-call ?name ?args]
+    (let [=name (unwrap-ident ?name)
+          ;; _ (prn '=name =name)
+          =args (map unwrap-ident ?args)
+          ;; _ (prn '=args =args)
+          =cases (map unwrap-tagged ?cases)
+          ;; _ (prn '=cases =cases)
+          ]
+      (return `(fn ~(symbol =name) ~(mapv symbol =args))))))
+
+(def compile-form
+  (try-all-m [compile-int
+              compile-ident
+              compile-tuple
+              compile-tagged
+              compile-if
+              compile-def
+              compile-defdata
+              compile-fn-call]))
+
+(defn compile [inputs]
+  (match ((repeat-m compile-form) inputs)
+    [::&util/ok [?state ?forms]]
+    (if (empty? (:forms ?state))
+      ?forms
+      (assert false (str "Unconsumed input: " ?state)))
+    
+    [::&util/failure ?message]
+    (assert false ?message)))
+
+(comment
+  
+  )
diff --git a/src/lang/interpreter.clj b/src/lang/interpreter.clj
index e79ec44d0..19fe71106 100644
--- a/src/lang/interpreter.clj
+++ b/src/lang/interpreter.clj
@@ -1,15 +1,24 @@
 (ns lang.interpreter
-  (:refer-clojure :exclude [eval resolve])
+  (:refer-clojure :exclude [eval resolve -' *'])
   (:require [clojure.core.match :refer [match]]
             (lang [util :as &util :refer [exec return* return fail fail*
                                           repeat-m try-m try-all-m map-m
                                           apply-m]]
                   [parser :as &parser]
-                  [lexer :as &lexer])
-            :reload))
+                  [lexer :as &lexer]
+                  [compiler :as &compiler])
+            :reload)
+  )
 
 (declare eval-form)
 
+;; (defonce _init_
+;;   (do (alter-var-root #'clojure.core/prn
+;;                       (constantly #(.println System/out (apply pr-str %&))))))
+
+(def <=' (fn [x] (fn [y] (<= x y))))
+(def -' (fn [x] (fn [y] (- x y))))
+
 ;; [Utils]
 (def ^:private +state+
   {:globals {"*" (fn [x] (fn [y] (* x y)))}
@@ -19,25 +28,42 @@
 (defn wrap [x]
   (update-in +state+ [:forms] conj x))
 
+(defn wrap-in [state x]
+  (assoc state :forms (list x)))
+
 (defn resolve [ident]
   (fn [state]
+    ;; (prn 'resolve ident (get-in state [:globals ident]) (get-in state [:globals]))
     (if-let [value (get-in state [:globals ident])]
       (return* state value)
       (fail* (str "Unrecognized identifier: " ident)))))
 
+(defn define [name value]
+  (fn [state]
+    ;; (prn 'define name value (assoc-in state [:globals name] value))
+    (return* (assoc-in state [:globals name] value) nil)))
+
 (defn fn-call [f args]
-  (return (reduce #(%1 %2) f args)))
+  ;; (prn 'fn-call/call f args (first args) (second args))
+  ;; (prn 'fn-call/output* (f (first args)))
+  ;; (prn 'fn-call/output* ((f (first args)) (second args)))
+  (let [output (reduce #(%1 %2) f args)]
+    ;; (prn 'fn-call/output output)
+    (return output)))
 
 (defmacro ^:private defeval [name match return]
   `(def ~name
      (fn [state#]
-       (let [token# (first (:forms state#))]
-         ;; (prn '~name token#)
-         (match token#
+       (let [~'*token* (first (:forms state#))]
+         ;; (prn '~name ~'*token*)
+         ;; (prn '~name state#)
+         (match ~'*token*
            ~match
-           (~return (update-in state# [:forms] rest))
+           (let [output# (~return (update-in state# [:forms] rest))]
+             ;; (prn "output#" output#)
+             output#)
            _#
-           (fail* (str "Unknown syntax: " (pr-str token#))))))))
+           (fail* (str "Unknown syntax: " (pr-str ~'*token*))))))))
 
 (defeval eval-ident
   [::&parser/ident ?ident]
@@ -49,16 +75,34 @@
 
 (defeval eval-def
   [::&parser/def ?form ?body]
-  (match ?form
-    [::&parser/fn-call ?name ?args]
-    (exec [=body (apply-m eval-form (wrap ?body))
-           =args (map-m (fn [arg] (apply-m eval-form (wrap arg)))
-                        ?args)]
-      (return `(fn ~(vec =args) ~=body)))))
+  (exec [;; :let [_ (prn 'eval-defdata ?form ?cases)]
+         =value (apply-m &compiler/compile-form (wrap *token*))
+         ;; :let [_ (prn 'eval-def 'DONE =value)]
+         :let [=name (match ?form
+                       [::&parser/fn-call [::&parser/ident ?name] ?args]
+                       ?name)
+               =value* (clojure.core/eval =value)
+               ;; _ (prn '=value* =value*)
+               ]
+         ]
+    (define =name =value*)))
+
+(defeval eval-defdata
+  [::&parser/defdata ?form & ?cases]
+  (exec [;; :let [_ (prn 'eval-defdata ?form ?cases)]
+         _ (apply-m &compiler/compile-form (wrap `[::&parser/defdata ~?form ~@?cases]))
+         ;; :let [_ (prn 'eval-defdata 'DONE)]
+         ]
+    (return nil)))
+
+;; [:lang.parser/defdata [:lang.parser/fn-call [:lang.parser/ident "List"] ([:lang.parser/ident "x"])]
+;;  ([:lang.parser/tagged "Nil" [:lang.parser/tuple ()]]
+;;     [:lang.parser/tagged "Cons" [:lang.parser/tuple ([:lang.parser/ident "x"] [:lang.parser/fn-call [:lang.parser/ident "List"] ([:lang.parser/ident "x"])])]])]
 
 (defeval eval-fn-call
   [::&parser/fn-call ?fn ?args]
-  (exec [=fn (apply-m eval-form (wrap ?fn))
+  (exec [state &util/get-state
+         =fn (apply-m eval-form (wrap-in state ?fn))
          =args (map-m (fn [arg] (apply-m eval-form (wrap arg)))
                       ?args)]
     (fn-call =fn =args)))
@@ -67,6 +111,7 @@
   (try-all-m [eval-ident
               eval-int
               eval-def
+              eval-defdata
               eval-fn-call]))
 
 ;; [::def [::fn-call [::ident "**"] ([::ident "base"] [::ident "exp"])]
@@ -75,11 +120,11 @@
 ;;                                 [::fn-call [::ident "repeat"] ([::ident "exp"]
 ;;                                                                [::ident "base"])])]]
 
-(defn eval [state]
-  (match (eval-form state)
-    [::&util/ok [?state ?datum]]
+(defn eval [text]
+  (match ((repeat-m eval-form) text)
+    [::&util/ok [?state ?forms]]
     (if (empty? (:forms ?state))
-      ?datum
+      ?forms
       (assert false (str "Unconsumed input: " ?state)))
     
     [::&util/failure ?message]
@@ -88,9 +133,14 @@
 (comment
   (let [source-code (slurp "src/example/test1.lang")
         tokens (&lexer/lex source-code)
-        syntax (&parser/parse (list tokens))]
-    ;; (prn 'syntax syntax)
-    (eval (update-in +state+ [:forms] concat (list syntax))))
+        _ (prn 'tokens tokens)
+        syntax (&parser/parse tokens)
+        _ (prn 'syntax syntax)]
+    (eval (update-in +state+ [:forms] concat syntax)))
+
+  
+
+  
 
   ;; (clojure.core/fn [base exp] (fold * 1 (repeat exp base)))
 
@@ -112,4 +162,6 @@
 
   ;; (def (** base exp)
   ;;   (fold * 1 (repeat exp base)))
+
+  
   )
diff --git a/src/lang/lexer.clj b/src/lang/lexer.clj
index 191686cb8..bbb92da95 100644
--- a/src/lang/lexer.clj
+++ b/src/lang/lexer.clj
@@ -1,5 +1,6 @@
 (ns lang.lexer
-  (:require [clojure.core.match :refer [match]]
+  (:require [clojure.template :refer [do-template]]
+            [clojure.core.match :refer [match]]
             [lang.util :as &util :refer [exec return* return fail fail*
                                          repeat-m try-m try-all-m]]))
 
@@ -10,13 +11,13 @@
   (fn [text]
     (if-let [[match] (re-find regex text)]
       (return* (.substring text (.length match)) match)
-      (fail* "Pattern failed."))))
+      (fail* (str "Pattern failed: " regex " -- " text)))))
 
-(defn ^:private lex-str [str]
+(defn ^:private lex-str [prefix]
   (fn [text]
-    (if (.startsWith text str)
-      (return* (.substring text (.length str)) str)
-      (fail* "String failed."))))
+    (if (.startsWith text prefix)
+      (return* (.substring text (.length prefix)) prefix)
+      (fail* (str "String failed: " prefix " -- " text)))))
 
 ;; [Lexers]
 (def ^:private lex-white-space (lex-regex #"^(\s+)"))
@@ -27,33 +28,43 @@
          _ (lex-str ")")]
     (return [::list members])))
 
-(def ^:private lex-ident
-  (exec [token (lex-regex #"^([a-zA-Z!@$%^&*<>\.,/\\\|][a-zA-Z0-9!@$%^&*<>\.,/\\\|]*)")]
-    (return [::ident token])))
+(def ^:private lex-tuple
+  (exec [_ (lex-str "[")
+         members (repeat-m lex-form)
+         _ (lex-str "]")]
+    (return [::tuple members])))
+
+(def +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|'][a-zA-Z0-9\-\+\_\=!@$%^&*<>\.,/\\\|']*)")
+
+(do-template [<name> <tag> <regex>]
+  (def <name>
+    (exec [token (lex-regex <regex>)]
+      (return [<tag> token])))
+
+  ^:private lex-int   ::int    #"^(0|[1-9][0-9]*)"
+  ^:private lex-ident ::ident  +ident-re+)
 
-(def ^:private lex-int
-  (exec [token (lex-regex #"^([1-9][0-9]*)")]
-    (return [::int token])))
+(def ^:private lex-tag
+  (exec [_ (lex-str "#")
+         token (lex-regex +ident-re+)]
+    (return [::tag token])))
 
 (def ^:private lex-form
   (exec [_ (try-m lex-white-space)
-         form (try-all-m [lex-list
+         form (try-all-m [lex-int
                           lex-ident
-                          lex-int
-                          ])
+                          lex-tag
+                          lex-list
+                          lex-tuple])
          _ (try-m lex-white-space)]
     (return form)))
 
 ;; [Interface]
 (defn lex [text]
-  (match ((exec [_ (try-m lex-white-space)
-                 form lex-list
-                 _ (try-m lex-white-space)]
-            (return form))
-          text)
-    [::&util/ok [?state ?datum]]
+  (match ((repeat-m lex-form) text)
+    [::&util/ok [?state ?forms]]
     (if (empty? ?state)
-      ?datum
+      ?forms
       (assert false (str "Unconsumed input: " ?state)))
     
     [::&util/failure ?message]
diff --git a/src/lang/parser.clj b/src/lang/parser.clj
index 289453999..985a17861 100644
--- a/src/lang/parser.clj
+++ b/src/lang/parser.clj
@@ -15,16 +15,22 @@
          ~match
          (~return left#)
          _#
-         (fail* "Unmatched token.")))))
+         (fail* (str "Unmatched token: " token#))))))
 
 ;; [Parsers]
+(defparser ^:private parse-int
+  [::&lexer/int ?int]
+  (return [::int (Long/parseLong ?int)]))
+
 (defparser ^:private parse-ident
   [::&lexer/ident ?ident]
   (return [::ident ?ident]))
 
-(defparser ^:private parse-int
-  [::&lexer/int ?int]
-  (return [::int (Long/parseLong ?int)]))
+(defparser ^:private parse-tuple
+  [::&lexer/tuple ?parts]
+  (exec [=parts (map-m (fn [arg] (apply-m parse-form (list arg)))
+                       ?parts)]
+    (return [::tuple =parts])))
 
 (defparser ^:private parse-def
   [::&lexer/list ([[::&lexer/ident "def"] ?name ?body] :seq)]
@@ -32,6 +38,30 @@
          =body (apply-m parse-form (list ?body))]
     (return [::def =name =body])))
 
+(defparser ^:private parse-defdata
+  [::&lexer/list ([[::&lexer/ident "defdata"] ?type & ?cases] :seq)]
+  (exec [=type (apply-m parse-form (list ?type))
+         =cases (map-m (fn [arg]
+                         (match arg
+                           [::&lexer/list ([[::&lexer/tag ?tag] ?data] :seq)]
+                           (exec [=data (apply-m parse-form (list ?data))]
+                             (return [::tagged ?tag =data]))
+                           ))
+                       ?cases)]
+    (return [::defdata =type =cases])))
+
+(defparser ^:private parse-if
+  [::&lexer/list ([[::&lexer/ident "if"] ?test ?then ?else] :seq)]
+  (exec [=test (apply-m parse-form (list ?test))
+         =then (apply-m parse-form (list ?then))
+         =else (apply-m parse-form (list ?else))]
+    (return [::if =test =then =else])))
+
+(defparser ^:private parse-tagged
+  [::&lexer/list ([[::&lexer/tag ?tag] ?data] :seq)]
+  (exec [=data (apply-m parse-form (list ?data))]
+    (return [::tagged ?tag =data])))
+
 (defparser ^:private parse-fn-call
   [::&lexer/list ([?f & ?args] :seq)]
   (exec [=f (apply-m parse-form (list ?f))
@@ -40,17 +70,21 @@
     (return [::fn-call =f =args])))
 
 (def ^:private parse-form
-  (try-all-m [parse-ident
-              parse-int
+  (try-all-m [parse-int
+              parse-ident
+              parse-tuple
               parse-def
+              parse-defdata
+              parse-if
+              parse-tagged
               parse-fn-call]))
 
 ;; [Interface]
-(defn parse [tokens]
-  (match (parse-form tokens)
-    [::&util/ok [?state ?datum]]
+(defn parse [text]
+  (match ((repeat-m parse-form) text)
+    [::&util/ok [?state ?forms]]
     (if (empty? ?state)
-      ?datum
+      ?forms
       (assert false (str "Unconsumed input: " ?state)))
     
     [::&util/failure ?message]
diff --git a/src/lang/util.clj b/src/lang/util.clj
index 1290d91df..d9745e9ab 100644
--- a/src/lang/util.clj
+++ b/src/lang/util.clj
@@ -58,12 +58,15 @@
   (fn [state]
     (match (monad state)
       [::ok [?state ?head]]
-      ((exec [tail (repeat-m monad)]
-         (return (cons ?head tail)))
-       ?state)
+      (do ;; (prn 'repeat-m/?state ?state)
+        (match ((repeat-m monad) ?state)
+          [::ok [?state* ?tail]]
+          (do ;; (prn 'repeat-m/?state* ?state*)
+            (return* ?state* (cons ?head ?tail)))))
       
-      [::failure _]
-      (return* state '()))))
+      [::failure ?message]
+      (do ;; (println "Failed at last:" ?message)
+        (return* state '())))))
 
 (defn try-all-m [monads]
   (fn [state]
@@ -90,7 +93,7 @@
   (fn [state]
     ;; (prn 'apply-m monad call-state)
     (let [output (monad call-state)]
-      ;; (prn 'output output)
+      ;; (prn 'apply-m/output output)
       (match output
         [::ok [?state ?datum]]
         [::ok [state ?datum]]
@@ -105,3 +108,7 @@
 (defn pass [m-value]
   (fn [state]
     m-value))
+
+(def get-state
+  (fn [state]
+    (return* state state)))