Start work on the interpreter

src/ludus/compile.clj

@@ -10,4 +10,25 @@
 
 (def result (->> source s/scan :tokens (p/apply-parser g/script)))
 
-(println result)
+(println result)
+
+(comment "
+	What sorts of compiling and validation do we want to do? Be specific.
+
+	- check used names are bound (validation)
+	- check bound names are available (validation)
+	- check `recur` is only ever in `loop` and in `fn` bodies (validation)
+	- separate function arities into different functions (optimization)
+	- desugar partially applied functions (simplification)
+	- desugar keyword entry shorthand (simplification)
+	- flag tail calls for optimization (optimization)
+		- direct tail calls
+		- through different expressions
+			- block
+			- if
+			- cond
+			- match
+			- let
+	- check ns access
+
+	")

src/ludus/grammar.clj

@@ -58,9 +58,11 @@
 
 (def constraint (order-0 :constraint [(quiet :when) expression]))
 
-(def pattern (choice :pattern [literal :ignored :placeholder :word :keyword tuple-pattern dict-pattern struct-pattern list-pattern]))
+(def typed (group (weak-order :typed [:word (quiet :as) :keyword])))
 
-(def match-clause (group (order-0 :match-clause 
+(def pattern (flat (choice :pattern [literal :ignored :placeholder typed :word :keyword tuple-pattern dict-pattern struct-pattern list-pattern])))
+
+(def match-clause (group (weak-order :match-clause 
                           	[pattern (maybe constraint) (quiet :rarrow) expression])))
 
 (def match-entry (weak-order :match-entry [match-clause terminators]))
@@ -73,26 +75,26 @@
                     	(quiet :rbrace)
                     	])))
 
-(def iff (order-1 :if [(quiet :if) 
+(def iff (group (order-1 :if [(quiet :if) 
-                      	nls? 
+                              nls? 
-                      	expression 
+                              expression 
-                      	nls? 
+                              nls? 
-                      	(quiet :then) 
+                              (quiet :then) 
-                      	expression 
+                              expression 
-                      	nls? 
+                              nls? 
-                      	(quiet :else) 
+                              (quiet :else) 
-                      	expression]))
+                              expression])))
 
 (def cond-lhs (flat (choice :cond-lhs [expression :placeholder :else])))
 
-(def cond-clause (group (order-0 :cond-clause [cond-lhs (quiet :rarrow) expression])))
+(def cond-clause (group (weak-order :cond-clause [cond-lhs (quiet :rarrow) expression])))
 
 (def cond-entry (weak-order :cond-entry [cond-clause terminators]))
 
-(def condd (order-1 :cond [(quiet :cond) (quiet :lbrace)
+(def condd (group (order-1 :cond [(quiet :cond) (quiet :lbrace)
-                          	(quiet (zero+ terminator))
+                                  (quiet (zero+ terminator))
-                          	(one+ cond-entry)
+                                  (one+ cond-entry)
-                          	(quiet :rbrace)]))
+                                  (quiet :rbrace)])))
 
 (def lett (group (order-1 :let [(quiet :let)
                                	pattern
@@ -147,19 +149,19 @@
 
 (def arg-expr (flat (choice :arg-expr [:placeholder expression])))
 
-(def arg-entry (order-1 :arg-entry [arg-expr separators]))
+(def arg-entry (weak-order :arg-entry [arg-expr separators]))
 
-(def arg-tuple (order-1 :arg-tuple
+(def args (group (order-1 :args
-                	[(quiet :lparen)
+                   [(quiet :lparen)
-                		(quiet (zero+ separator))
+                    (quiet (zero+ separator))
-                		(zero+ arg-entry)
+                    (zero+ arg-entry)
-                		(quiet :rparen)]))
+                    (quiet :rparen)])))
 
-(def synth-root (choice :synth-root [:keyword :word :recur]))
+(def synth-root (flat (choice :synth-root [:keyword :word :recur])))
 
-(def synth-term (choice :synth-term [arg-tuple :keyword]))
+(def synth-term (flat (choice :synth-term [args :keyword])))
 
-(def synthetic (order-1 :synthetic [synth-root (zero+ synth-term)]))
+(def synthetic (group (order-1 :synthetic [synth-root (zero+ synth-term)])))
 
 (def fn-clause (group (order-0 :fn-clause [tuple-pattern (maybe constraint) (quiet :rarrow) expression])))
 
@@ -185,7 +187,7 @@
 
 (def block (group (order-1 :block [(quiet :lbrace) 
                                   	(quiet (zero+ terminator))
-                                  	(zero+ block-line)
+                                  	(one+ block-line)
                                   	(quiet :rbrace)])))
 
 (def pipeline (order-0 :pipeline [nls? :pipeline]))
@@ -255,4 +257,38 @@
 
 (def script (order-0 :script [nls?
                               (one+ script-line)
-                              (quiet :eof)]))
+                              (quiet :eof)]))
+
+
+;;; REPL
+
+(comment (def source 
+           "if 1 then 2 else 3"
+           )
+
+  (def result (apply-parser script source))  
+
+
+  (defn report [node] 
+    (when (fail? node) (err-msg node))  
+    node)   
+
+  (defn clean [node]  
+    (if (map? node) 
+      (-> node    
+        (report)    
+        (dissoc     
+          ;:status     
+          :remaining  
+          :token) 
+        (update :data #(into [] (map clean) %)))    
+      node))  
+
+  (defn tap [x] (println "\n\n\n\n******NEW RUN\n\n:::=> " x "\n\n") x)   
+
+  (def my-data (-> result     
+                 clean   
+                 tap 
+                 ))
+
+  (println my-data))

src/ludus/interpreter.clj

@@ -1,6 +1,8 @@
 (ns ludus.interpreter
   (:require
     [ludus.parser :as parser]
+    [ludus.parser-new :as p]
+    [ludus.grammar :as g]
     [ludus.scanner :as scanner]
     [ludus.ast :as ast]
     [ludus.prelude :as prelude]
@@ -27,9 +29,9 @@
         ::not-found))))
 
 (defn- resolve-word [word ctx]
-  (let [value (ludus-resolve (:word word) ctx)]
+  (let [value (ludus-resolve (-> word :data first) ctx)]
     (if (= ::not-found value)
-      (throw (ex-info (str "Unbound name: " (:word word)) {:ast word}))
+      (throw (ex-info (str "Unbound name: " (-> word :data first)) {:ast word}))
       value)))
 
 (declare interpret-ast match interpret interpret-file)
@@ -95,16 +97,16 @@
 
     :else 
     (let [members (:members pattern)
-      ctx-diff (volatile! @ctx-vol)]
+          ctx-diff (volatile! @ctx-vol)]
-            (loop [i (dec (count members))]
+      (loop [i (dec (count members))]
-              (if (> 0 i)
+        (if (> 0 i)
-                {:success true :ctx @ctx-diff}
+          {:success true :ctx @ctx-diff}
-                (let [match? (match (nth members i) (nth value i) ctx-diff)]
+          (let [match? (match (nth members i) (nth value i) ctx-diff)]
-                  (if (:success match?)
+            (if (:success match?)
-                    (do
+              (do
-                      (vswap! ctx-diff #(merge % (:ctx match?))) 
+                (vswap! ctx-diff #(merge % (:ctx match?))) 
-                      (recur (dec i)))
+                (recur (dec i)))
-                    {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))})))))))
+              {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))})))))))
 
 (defn- match-dict [pattern value ctx-vol]
   (cond
@@ -131,7 +133,7 @@
                     (recur (dec i)))
                   {:success false :reason (str "Could not match " pattern " with " value " at key " kw " because " (:reason match?))}))
               {:success false
-                :reason (str "Could not match " pattern " with " value " at key " kw " because there is no value at " kw)})))))))
+               :reason (str "Could not match " pattern " with " value " at key " kw " because there is no value at " kw)})))))))
 
 (defn- match-struct [pattern value ctx-vol]
   (cond
@@ -158,42 +160,86 @@
                   {:success false :reason (str "Could not match " pattern " with " value " at key " kw " because " (:reason match?))}))
               {:success false :reason (str "Could not match " pattern " with " value " at key " kw ", because there is no value at " kw)})))))))
 
+(defn- get-type [value]
+  (let [t (type value)]
+    (cond
+      (nil? value) :nil
+
+      (= clojure.lang.Keyword t) :keyword
+
+      (= java.lang.Long t) :number
+
+      (= java.lang.Double t) :number
+
+      (= java.lang.String t) :string
+
+      (= java.lang.Boolean t) :boolean
+
+      (= clojure.lang.PersistentHashSet t) :set
+
+      ;; tuples and lists
+      (= clojure.lang.PersistentVector t)
+      (if (= ::data/tuple (first value)) :tuple :list)
+
+      ;; structs dicts namespaces refs
+      (= clojure.lang.PersistentArrayMap t)
+      (cond
+        (::data/dict value) :dict
+        (::data/struct value) :struct
+        :else :none
+        )
+
+      )))
+
+(get-type [::data/tuple])
+
+(defn- match-typed [pattern value ctx]
+  (let [data (:data pattern)
+        name (-> data first :data)
+        type (-> data second :data)]
+    (cond
+      (contains? ctx name) {:success false :reason (str "Name " name "is already bound") :code :name-error}
+      (not (= type (get-type value))) {:success false :reason (str "Could not match " pattern " with " value ", because types do not match")}
+      :else {:success true :ctx {name value}})))
+
 (defn- match [pattern value ctx-vol]
   (let [ctx @ctx-vol]
-    (case (::ast/type pattern)
+    (case (:type pattern)
-      ::ast/placeholder {:success true :ctx {}}
+      (:placeholder :ignored)
+      {:success true :ctx {}}
 
-      ::ast/atom
+      (:number :nil :true :false :string :keyword)
-      (let [match-value (:value pattern)]
+      (let [match-value (-> pattern :data first)]
         (if (= match-value value)
           {:success true :ctx {}}
           {:success false
            :reason (str "No match: Could not match " match-value " with " value)}))
 
-      ::ast/word
+      :word
-      (let [word (:word pattern)]
+      (let [word (-> pattern :data first)]
         (if (contains? ctx word)
           {:success false :reason (str "Name " word " is already bound") :code :name-error}
           {:success true :ctx {word value}}))
 
-      ::ast/tuple (match-tuple pattern value ctx-vol)
+      :typed (match-typed pattern value ctx)
 
-      ::ast/list (match-list pattern value ctx-vol)
+      :tuple (match-tuple pattern value ctx-vol)
 
-      ::ast/dict (match-dict pattern value ctx-vol)
+      :list (match-list pattern value ctx-vol)
 
-      ::ast/struct (match-struct pattern value ctx-vol)
+      :dict (match-dict pattern value ctx-vol)
+
+      :struct (match-struct pattern value ctx-vol)
 
       (throw (ex-info "Unknown pattern on line " {:pattern pattern})))))
 
 (defn- update-ctx [ctx new-ctx]
   (merge ctx new-ctx))
 
-;; TODO: get "if let" pattern working
-;; TODO: get typed exceptions to distinguish panics
 (defn- interpret-let [ast ctx]
-  (let [pattern (:pattern ast)
+  (let [data (:data ast)
-        expr (:expr ast)
+        pattern (first data)
+        expr (second data)
         value (interpret-ast expr ctx)
         match (match pattern value ctx)
         success (:success match)]
@@ -203,59 +249,76 @@
     value))
 
 (defn- interpret-if-let [ast ctx]
-	(let [if-ast (:if ast)
+ 	(let [data (:data ast)
-		  then-expr (:then ast)
+        if-ast (first data)
-		  else-expr (:else ast)
+    		  then-expr (second data)
-		  if-pattern (:pattern if-ast)
+    		  else-expr (nth data 2)
-		  if-expr (:expr if-ast)
+        if-data (:data if-ast)
-		  if-value (interpret-ast if-expr ctx)
+    		  let-pattern (first if-data)
-		  if-match (match if-pattern if-value ctx)
+    		  let-expr (second if-data)
-		  success (:success if-match)]
+    		  let-value (interpret-ast let-expr ctx)
-		(if success
+    		  if-match (match let-pattern let-value ctx)
-			(interpret-ast then-expr (volatile! (merge (:ctx if-match) {:parent ctx})))
+    		  success (:success if-match)]
-			(if (:code if-match)
+  		(if success
-				(throw (ex-info (:reason if-match) {:ast if-ast}))
+   			(interpret-ast then-expr (volatile! (merge (:ctx if-match) {:parent ctx})))
-				(interpret-ast else-expr ctx)))))
+   			(if (:code if-match)
+    				(throw (ex-info (:reason if-match) {:ast if-ast}))
+    				(interpret-ast else-expr ctx)))))
 
 (defn- interpret-if [ast ctx]
-  (let [if-expr (:if ast)
+  (let [data (:data ast)
-        then-expr (:then ast)
+        if-expr (first data)
-        else-expr (:else ast)]
+        then-expr (second data)
-     (if (= (::ast/type if-expr) ::ast/let)
+        else-expr (nth data 2)]
-        (interpret-if-let ast ctx)
+    (if (= (:type if-expr) :let)
-        (if (interpret-ast if-expr ctx)
+      (interpret-if-let ast ctx)
-        	 (interpret-ast then-expr ctx)
+      (if (interpret-ast if-expr ctx)
-        	 (interpret-ast else-expr ctx)))))
+      	 (interpret-ast then-expr ctx)
+      	 (interpret-ast else-expr ctx)))))
 
 (defn- interpret-match [ast ctx]
-  (let [match-expr (:expr ast)
+  (let [data (:data ast)
-        expr (interpret-ast match-expr ctx)
+        match-expr (first data)
-        clauses (:clauses ast)]
+        value (interpret-ast match-expr ctx)
+        clauses (rest data)]
     (loop [clause (first clauses)
            clauses (rest clauses)]
       (if clause
-        (let [pattern (:pattern clause)
+        (let [clause-data (:data clause)
-              body (:body clause)
+              pattern (first clause-data)
+              constraint (if (= 3 (count clause-data))
+                           (second clause-data)
+                           nil)
+              body (peek clause-data)
               new-ctx (volatile! {::parent ctx})
-              match? (match pattern expr new-ctx)
+              match? (match pattern value new-ctx)
               success (:success match?)
               clause-ctx (:ctx match?)]
-          (if success
+          (if success            
             (do
               (vswap! new-ctx #(merge % clause-ctx))
-              (interpret-ast body new-ctx))
+              (if constraint
+                (if (interpret-ast constraint new-ctx)
+                  (interpret-ast body new-ctx)
+                  (recur (first clauses) (rest clauses)))
+                (interpret-ast body new-ctx)))
             (recur (first clauses) (rest clauses))))
         (throw (ex-info "Match Error: No match found" {:ast ast}))))))
 
 (defn- interpret-cond [ast ctx]
-  (let [clauses (:clauses ast)]
+  (let [clauses (:data ast)]
     (loop [clause (first clauses)
            clauses (rest clauses)]
       (if (not clause)
         (throw (ex-info "Cond Error: No match found" {:ast ast}))
-        (let [test-expr (:test clause)
+        (let [data (:data clause)
-              body (:body clause)
+              test-expr (first data)
-              truthy? (boolean (interpret-ast test-expr ctx))]
+              test-type (:type test-expr)
+              body (second data)
+              truthy? (or
+                        (= :placeholder test-type)
+                        (= :else test-type)
+                        (interpret-ast test-expr ctx))]
           (if truthy?
             (interpret-ast body ctx)
             (recur (first clauses) (rest clauses))))))))
@@ -322,28 +385,48 @@
 
     :else (throw (ex-info "I don't know how to call that" {:ast lfn}))))
 
+(defn- validate-args [args]
+  (>= 1 (count (filter #(= :placeholder (:type %)) args))))
+
+(defn- partial? [args]
+  (some #(= :placeholder (:type %)) args))
+
+(defn- interpret-args [ast ctx]
+  (let [members (:data ast)]
+    (if (partial? args)
+      (if (validate-args)
+        () ; do the thing
+        (throw (ex-info "Partially applied functions may only take a single argument")))
+      (map #(interpret-ast % ctx) args)
+      )))
+
 (defn- interpret-synthetic-term [prev-value curr ctx]
-  (let [type (::ast/type curr)]
+  (let [type (:type curr)
-    (if (= type ::ast/atom)
+        data (:data curr)]
+    (if (= type :keyword)
       (if (::data/struct prev-value)
-        (if (contains? prev-value (:value curr))
+        (if (contains? prev-value (first data))
-          (get prev-value (:value curr))
+          (get prev-value (first data))
           (if (= (::data/type prev-value) ::data/ns)
             (throw (ex-info (str "Namespace error: no member " (:value curr) " in ns " (::data/name prev-value)) {:ast curr}))
             (throw (ex-info (str "Struct error: no member " (:value curr)) {:ast curr}))))
-        (get prev-value (:value curr)))
+        (get prev-value (first data)))
-      (call-fn prev-value (interpret-ast curr ctx) ctx))))
+      (call-fn prev-value (interpret-args curr ctx) ctx))))
 
 (defn- interpret-synthetic [ast ctx]
-  (let [terms (:terms ast)
+  (let [data (:data ast)
-        first (first terms)
+        first-term (first data)
-        second (second terms)
+        terms (-> data second :data)]
-        rest (rest (rest terms))
+    (if terms
-        first-term-type (::ast/type first)
+      (let [second-term (first terms)
-        first-val (if (= first-term-type ::ast/atom)
+            rest (rest terms)
-                    (interpret-called-kw first second ctx)
+            first-val (if (= (:type first) :keyword)
-                    (interpret-synthetic-term (interpret-ast first ctx) second ctx))]
+                        (interpret-called-kw first-term second-term ctx)
-    (reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest)))
+                        (interpret-synthetic-term (interpret-ast first-term ctx) second-term ctx))]
+        (reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest))
+      (do
+        ;(println "interpreting " (:type first-term))
+        (interpret-ast first-term ctx)))))
 
 (defn- interpret-fn [ast ctx] ;; TODO: fix context/closure (no cycles)?
   (let [name (:name ast)
@@ -548,23 +631,26 @@
         (swap! process #(assoc % :status :dead))))
     pid))
 
+(defn- interpret-literal [ast] (-> ast :data first))
+
 (defn interpret-ast [ast ctx]
-  (case (::ast/type ast)
+  (println "interpreting ast type" (:type ast))
-    ::ast/self self
+  ;(println "AST: " ast)
+  (case (:type ast)
 
-    ::ast/atom (:value ast)
+    (:nil :true :false :number :string :keyword) (interpret-literal ast)
 
-    ::ast/word (resolve-word ast ctx)
+    :let (interpret-let ast ctx)
 
-    ::ast/let (interpret-let ast ctx)
+    :if (interpret-if ast ctx)
 
-    ::ast/if (interpret-if ast ctx)
+    :word (resolve-word ast ctx)
 
-    ::ast/match (interpret-match ast ctx)
+    :synthetic (interpret-synthetic ast ctx)
 
-    ::ast/cond (interpret-cond ast ctx)
+    :match (interpret-match ast ctx)
 
-    ::ast/synthetic (interpret-synthetic ast ctx)
+    :cond (interpret-cond ast ctx)
 
     ::ast/fn (interpret-fn ast ctx)
 
@@ -591,7 +677,7 @@
 
     ::ast/loop (interpret-loop ast ctx)
 
-    ::ast/block
+    :block
     (let [exprs (:exprs ast)
           inner (pop exprs)
           last (peek exprs)
@@ -599,8 +685,8 @@
       (run! #(interpret-ast % ctx) inner)
       (interpret-ast last ctx))
 
-    ::ast/script
+    :script
-    (let [exprs (:exprs ast)
+    (let [exprs (:data ast)
           inner (pop exprs)
           last (peek exprs)]
       (run! #(interpret-ast % ctx) inner)
@@ -609,16 +695,13 @@
     ;; note that, excepting tuples and structs,
     ;; runtime representations are bare
     ;; tuples are vectors with a special first member
-    ::ast/tuple
+    :tuple
-    (let [members (:members ast)]
+    (let [members (:data ast)]
-      (into
+      (into [::data/tuple] (map #(interpret-ast % ctx)) members))
-        [(if (:partial ast) ::data/partial ::data/tuple)]
-        (map #(interpret-ast % ctx)) members))
 
     ::ast/list (interpret-list ast ctx)
 
-    ::ast/set
+    ::ast/set (interpret-set ast ctx)
-    (interpret-set ast ctx)
 
     ::ast/dict (interpret-dict ast ctx)
 
@@ -660,14 +743,14 @@
           process (process/new-process)]
       (process/start-vm)
       (with-bindings {#'self (:pid @process)}
-        (let [result (interpret-ast (::parser/ast parsed) base-ctx)]
+        (let [result (interpret-ast parsed base-ctx)]
           (swap! process #(assoc % :status :dead))
           (process/stop-vm)
           result)))
     (catch clojure.lang.ExceptionInfo e
       (process/stop-vm)
       (println "Ludus panicked!")
-      (println "On line" (get-in (ex-data e) [:ast :token ::token/line]))
+      (println "On line" (get-in (ex-data e) [:ast :token :line]))
       (println (ex-message e))
       (pp/pprint (ex-data e)))))
 
@@ -699,30 +782,30 @@
          )))))
 
 
-(comment
+(do
   (process/start-vm)
   (def source "
-    let #{a, a} = #{:a 1}
+    id (1)
-    a
+      ")
-    ")
 
   (println "")
   (println "****************************************")
   (println "*** *** NEW INTERPRETATION *** ***")
   (println "")
 
-  (let [result (-> source
+  (let [result (->> source
-                 (scanner/scan)
+                 scanner/scan
-                 (parser/parse)
+                 :tokens
-                 (interpret-safe)
+                 (p/apply-parser g/script)
-                 (show/show)
+                 interpret-safe
+                 ;(show/show)
                  )]
+    (println result)
     result))
 
 (comment "
 
 	Left to do:
-	x if-let pattern
 	* improve panics
 	* add location info for panics
   * refactor calling keywords

src/ludus/interpreter_new.clj

@@ -0,0 +1,41 @@
+(ns ludus.interpreter-new
+ 	(:require
+  		[ludus.grammar :as g]
+  		[ludus.parser-new :as p]
+  		[ludus.scanner :as s]))
+
+(def source 
+  "
+foo (1, _)
+  "
+  )
+
+(def tokens (-> source s/scan :tokens))
+
+(def result (p/apply-parser g/script tokens))	
+
+(-> result :data) 
+
+(defn report [node]	
+ 	(when (p/fail? node) (p/err-msg node))	
+ 	node)	
+
+(defn clean [node]	
+ 	(if (map? node)	
+  		(-> node	
+   			(report)	
+   			(dissoc 	
+    				:status 	
+    				:remaining 	
+    				:token)	
+   			(update :data #(into [] (map clean) %)))	
+  		node))	
+
+(defn tap [x] (println "\n\n\n\n******NEW RUN\n\n:::=> " x "\n\n") x)	
+
+(def my-data (-> result 	
+              	clean 	
+              	tap	
+              	))
+
+(println my-data)

src/ludus/parser_new.clj

@@ -253,7 +253,7 @@
              							(:ok :group :quiet) 
              							{:status :group
  	            							:type name 
- 	            							:data (vec (concat [first-result] (data rest-result)))
+ 	            							:data (vec (concat (:data first-result) (data rest-result)))
  	            							:token (first tokens)
  	            							:remaining (remaining rest-result)}
 

src/ludus/prelude.clj

@@ -95,10 +95,13 @@
            :body get})
 
 (def draw {:name "draw"
-  ::data/type ::data/clj
+           ::data/type ::data/clj
-  :body d/ludus-draw})
+           :body d/ludus-draw})
 
-(def prelude {"eq" eq
+(def prelude {
+              "foo" :foo
+              "bar" :bar
+              "eq" eq
               "add" add
               "print" print-
               "sub" sub