Keep knocking 'em down: fns, loops, pipelines work

src/ludus/compile.clj

@@ -16,11 +16,11 @@
 	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 bound names are free (validation)
-	- check `recur` is only ever in `loop` and in `fn` bodies (validation)
+	- check `recur` is only ever in `loop` (and in `fn` bodies?), in tail position (validation)
 	- separate function arities into different functions (optimization)
-	- desugar partially applied functions (simplification)
+	- desugar partially applied functions (?) (simplification)
-	- desugar keyword entry shorthand (simplification)
+	- desugar keyword entry shorthand (?) (simplification)
 	- flag tail calls for optimization (optimization)
 		- direct tail calls
 		- through different expressions
@@ -29,6 +29,6 @@
 			- cond
 			- match
 			- let
-	- check ns access
+	- check ns access (validation)
 
 	")

src/ludus/grammar.clj

@@ -163,7 +163,7 @@
 
 (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])))
+(def fn-clause (group (order-1 :fn-clause [tuple-pattern (maybe constraint) (quiet :rarrow) expression])))
 
 (def fn-entry (order-1 :fn-entry [fn-clause terminators]))
 

src/ludus/interpreter.clj

@@ -57,23 +57,27 @@
               )))))))
 
 (defn- match-tuple [pattern value ctx-vol]
+  ;(println "\n\n\n**********Matching tuple")
+  ;(println "*****Value:   " value)
+  ;(println "*****Pattern: " pattern)
+  (let [members (:data pattern)
+        length (count members)]
     (cond
       (not (vector? value)) {:success false :reason "Could not match non-tuple value to tuple"}
   
       (not (= ::data/tuple (first value))) {:success false :reason "Could not match list to tuple"}
   
-    (= ::ast/splat (::ast/type (last (:members pattern))))
+      (= ::ast/splat (::ast/type (last members)))
       (match-splatted-tuple pattern value ctx-vol)
   
-    (not (= (:length pattern) (dec (count value))))
+      (not (= length (dec (count value))))
       {:success false :reason "Cannot match tuples of different lengths"}
   
-    (= 0 (:length pattern) (dec (count value))) {:success true :ctx {}}
+      (= 0 length (dec (count value))) {:success true :ctx {}}
   
       :else 
-    (let [members (:members pattern)
+      (let [ctx-diff (volatile! @ctx-vol)]
-          ctx-diff (volatile! @ctx-vol)]
+        (loop [i length]
-      (loop [i (:length pattern)]
           (if (= 0 i)
             {:success true :ctx @ctx-diff}
             (let [match? (match (nth members (dec i)) (nth value i) ctx-diff)]
@@ -81,7 +85,7 @@
                 (do
                   (vswap! ctx-diff #(merge % (:ctx match?)))
                   (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-list [pattern value ctx-vol]
   (cond
@@ -128,7 +132,7 @@
               (let [match? (match (kw members) (kw value) ctx-diff)]
                 (if (:success match?)
                   (do
-                    (println (:ctx match?))
+                    ;(println (:ctx match?))
                     (vswap! ctx-diff #(merge % (:ctx match?)))
                     (recur (dec i)))
                   {:success false :reason (str "Could not match " pattern " with " value " at key " kw " because " (:reason match?))}))
@@ -160,49 +164,17 @@
                   {: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")}
+      (not (= type (prelude/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]
+  ;(println "Matching " value " with pattern type " (:type pattern))
   (let [ctx @ctx-vol]
     (case (:type pattern)
       (:placeholder :ignored)
@@ -223,15 +195,15 @@
 
       :typed (match-typed pattern value ctx)
 
-      :tuple (match-tuple pattern value ctx-vol)
+      :tuple-pattern (match-tuple pattern value ctx-vol)
 
-      :list (match-list pattern value ctx-vol)
+      :list-pattern (match-list pattern value ctx-vol)
 
-      :dict (match-dict pattern value ctx-vol)
+      :dict-pattern (match-dict pattern value ctx-vol)
 
-      :struct (match-struct pattern value ctx-vol)
+      :struct-pattern (match-struct pattern value ctx-vol)
 
-      (throw (ex-info "Unknown pattern on line " {:pattern pattern})))))
+      (throw (ex-info "Unknown pattern on line " {:pattern pattern :value value})))))
 
 (defn- update-ctx [ctx new-ctx]
   (merge ctx new-ctx))
@@ -295,12 +267,14 @@
               success (:success match?)
               clause-ctx (:ctx match?)]
           (if success
+            (if constraint 
+              (if (interpret-ast constraint (volatile! clause-ctx))
                 (do
                   (vswap! new-ctx #(merge % clause-ctx))
-              (if constraint
+                  (interpret-ast body new-ctx))
-                (if (interpret-ast constraint new-ctx)
-                  (interpret-ast body new-ctx)
                 (recur (first clauses) (rest clauses)))
+              (do
+                (vswap! new-ctx #(merge % clause-ctx))
                 (interpret-ast body new-ctx)))
             (recur (first clauses) (rest clauses))))
         (throw (ex-info "Match Error: No match found" {:ast ast}))))))
@@ -323,10 +297,24 @@
             (interpret-ast body ctx)
             (recur (first clauses) (rest clauses))))))))
 
+(defn- validate-args [args]
+  (>= 1 (count (filter #(= :placeholder (:type %)) args))))
+
+(defn- partial? [args]
+  (some #(= :placeholder (:type %)) args))
+
 (defn- interpret-called-kw [kw tuple ctx]
+  (let [members (:data tuple)
+        length (count members)]
     ;; TODO: check this statically
-  (if (not (= 1 (:length tuple)))
+    (cond 
-    (throw (ex-info "Called keywords must be unary" {:ast kw}))
+      (not (= 1 length)) 
+      (throw (ex-info "Called keywords must be unary" {:ast tuple}))
+
+      (partial? tuple) 
+      (throw (ex-info "Called keywords may not be partially applied" {:ast tuple}))
+
+      :else
       (let [kw (interpret-ast kw ctx)
             map (second (interpret-ast tuple ctx))]
         (if (::data/struct map)
@@ -335,44 +323,62 @@
             (if (= (::data/type map) ::data/ns)
               (throw (ex-info (str "Namespace error: no member " kw " in ns " (::data/name map)) {:ast kw}))
               (throw (ex-info (str "Struct error: no member at " kw) {:ast kw}))))
-        (get map kw)))))
+          (get map kw))))))
 
-(defn- call-fn [lfn tuple ctx]
+(defn- call-fn [lfn args ctx]
   (cond
-    (= ::data/partial (first tuple))
+    (= ::data/partial (first args))
     {::data/type ::data/clj
      :name (str (:name lfn) "{partial}")
      :body (fn [arg]
              (call-fn
                lfn
-               (concat [::data/tuple] (replace {::data/placeholder arg} (rest tuple)))
+               (concat [::data/tuple] (replace {::data/placeholder arg} (rest args)))
                ctx))}
 
-    (= (::data/type lfn) ::data/clj) (apply (:body lfn) (next tuple))
+    (= (::data/type lfn) ::data/clj) (apply (:body lfn) (next args))
 
     (= (::data/type lfn) ::data/fn)
     (let [clauses (:clauses lfn)
           closed-over (:ctx lfn)]
       (loop [clause (first clauses)
              clauses (rest clauses)]
+        ;(println "Matching clause " clause)
+        ;(println "With args " args)
         (if clause
-          (let [pattern (:pattern clause)
+          (let [pattern (first clause)
-                body (:body clause)
+                constraint (if (= 3 (count clause))
+                             (second clause)
+                             nil)
+                body (peek clause)
                 fn-ctx (volatile! {::parent closed-over})
-                match? (match pattern tuple fn-ctx)
+                match? (match pattern args fn-ctx)
                 success (:success match?)
-                clause-ctx (:ctx match?)]
+                clause-ctx (:ctx match?)
+                vclause (volatile! (assoc clause-ctx ::parent closed-over))]
+            ;(println "Pattern: " pattern)
+            ;(println "Body: " body)
             (if success
+              (if constraint 
+                (if (do
+                      ;(println "######### Testing constraint")
+                      ;(println "Context: " clause-ctx)
+                      (interpret-ast constraint vclause))
                   (do
+                    ;(println "passed constraint")
                     (vswap! fn-ctx #(merge % clause-ctx))
                     (interpret-ast body fn-ctx))
+                  (recur (first clauses) (rest clauses)))
+                (do
+                  (vswap! fn-ctx #(merge % clause-ctx))
+                  (interpret-ast body fn-ctx)))
               (recur (first clauses) (rest clauses))))
 
           (throw (ex-info "Match Error: No match found" {:ast (:ast lfn)})))))
 
     (keyword? lfn)
-    (if (= 2 (count tuple))
+    (if (= 2 (count args))
-      (let [target (second tuple) kw lfn]
+      (let [target (second args) kw lfn]
         (if (::data/struct target)
           (if (contains? target kw)
             (kw target)
@@ -385,24 +391,20 @@
 
     :else (throw (ex-info "I don't know how to call that" {:ast lfn}))))
 
-(defn- validate-args [args]
+(defn- interpret-args [args ctx]
-  (>= 1 (count (filter #(= :placeholder (:type %)) args))))
+  ;(println "interpreting arg" args)
-
-(defn- partial? [args]
-  (some #(= :placeholder (:type %)) args))
-
-(defn- interpret-args [ast ctx]
-  (let [members (:data ast)]
   (if (partial? args)
-      (if (validate-args)
+    (if (validate-args args)
-        () ; do the thing
+      (into [::data/partial] (map #(interpret-ast % ctx)) args) ; do the thing
-        (throw (ex-info "Partially applied functions may only take a single argument")))
+      (throw (ex-info "Partially applied functions may only take a single argument" {:ast args})))
-      (map #(interpret-ast % ctx) args)
+    (into [::data/tuple] (map #(interpret-ast % ctx)) args))
-      )))
+  )
 
 (defn- interpret-synthetic-term [prev-value curr ctx]
   (let [type (:type curr)
         data (:data curr)]
+    ;(println "interpreting synthetic type " type)
+    ;(println "interpreting synthetic node " curr)
     (if (= type :keyword)
       (if (::data/struct prev-value)
         (if (contains? prev-value (first data))
@@ -411,24 +413,26 @@
             (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 (first data)))
-      (call-fn prev-value (interpret-args curr ctx) ctx))))
+      (call-fn prev-value (interpret-args data ctx) ctx))))
 
 (defn- interpret-synthetic [ast ctx]
+  ;;(println "interpreting synthetic " ast)
   (let [data (:data ast)
-        first-term (first data)
+        root (first data)
-        terms (-> data second :data)]
+        terms (rest data)]
-    (if terms
+    ;(println "!!!!!!!!!Interpreting synthetic w/ root " (:data root))
-      (let [second-term (first terms)
+    (if (seq terms)
-            rest (rest terms)
-            first-val (if (= (:type first) :keyword)
-                        (interpret-called-kw first-term second-term ctx)
-                        (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))
+        ;;(println "I've got terms!: " terms)
-        (interpret-ast first-term ctx)))))
+        (let [first-term (first terms)
+              remaining (rest terms)
+              first-val (if (= (:type root) :keyword)
+                          (interpret-called-kw root first-term ctx)
+                          (interpret-synthetic-term (interpret-ast root ctx) first-term ctx))]
+          (reduce #(interpret-synthetic-term %1 %2 ctx) first-val remaining)))
+      (interpret-ast root ctx))))
 
-(defn- interpret-fn [ast ctx] ;; TODO: fix context/closure (no cycles)?
+(defn- interpret-fn-inner [ast ctx] ;; TODO: fix context/closure (no cycles)?
   (let [name (:name ast)
         clauses (:clauses ast)]
     (if (= name ::ast/anon)
@@ -447,11 +451,44 @@
             (vswap! ctx update-ctx {name fn})
             fn))))))
 
+(defn- build-fn
+  ([ast ctx name clauses] (build-fn ast ctx name clauses nil))
+  ([ast ctx name clauses docstring]
+   (let [fnn {::data/type ::data/fn
+              :name name
+              :ast ast
+              :clauses clauses
+              :ctx ctx
+              :doc docstring}]
+     (if (= name :anon) 
+       fnn
+       (if (contains? @ctx name)
+         (throw (ex-info (str "Name " name " is already bound") {:ast ast}))
+         (do
+           (vswap! ctx update-ctx {name fnn})
+           fnn))))))
+
+(defn- build-named-fn [ast ctx data]
+  (let [name (-> data first :data first)
+        body (-> data second)
+        compound? (= :compound (:type body))]
+    (if compound?
+      (if (= :string (-> body :data first :type))
+        (build-fn ast ctx name (map :data (rest (:data body))) (-> body :data first :data))
+        (build-fn ast ctx name (map :data (:data body))))
+      (build-fn ast ctx name [(:data body)]))))
+
+(defn- interpret-fn [ast ctx]
+  (let [data (:data ast)]
+    (case (:type (first data))
+      :fn-clause (build-fn ast ctx :anon (-> data first :data))
+      :named (build-named-fn ast ctx (-> data first :data)))))
+
 (defn- interpret-do [ast ctx]
-  (let [exprs (:exprs ast)
+  (let [data (:data ast)
-        origin (interpret-ast (first exprs) ctx)
+        root (interpret-ast (first data) ctx)
-        fns (rest exprs)]
+        fns (rest data)]
-    (reduce #(call-fn (interpret-ast %2 ctx) [::data/tuple %1] ctx) origin fns)))
+    (reduce #(call-fn (interpret-ast %2 ctx) [::data/tuple %1] ctx) root fns)))
 
 (defn- map-values [f]
   (map (fn [kv]
@@ -501,27 +538,40 @@
       ref)))
 
 (defn- interpret-loop [ast ctx]
-  (let [tuple (interpret-ast (:expr ast) ctx)
+  (let [data (:data ast)
-        clauses (:clauses ast)]
+        tuple (interpret-ast (first data) ctx)
+        loop-type (-> data second :type)
+        clauses (if (= loop-type :fn-clause)
+                  [(-> data second :data)]
+                  (into [] (map :data) (-> data second :data)))]
     (loop [input tuple]
       (let [output (loop [clause (first clauses)
                           clauses (rest clauses)]
                      (if clause
-                       (let [pattern (:pattern clause)
+                       (let [pattern (first clause)
-                             body (:body clause)
+                             constraint (if (= 3 (count clause))
+                                          (second clause)
+                                          nil)
+                             body (peek clause)
                              new-ctx (volatile! {::parent ctx})
                              match? (match pattern input new-ctx)
                              success (:success match?)
                              clause-ctx (:ctx match?)]
                          (if success
+                           (if constraint 
+                             (if (interpret-ast constraint (volatile! (assoc clause-ctx ::parent ctx)))
                                (do
                                  (vswap! new-ctx #(merge % clause-ctx))
                                  (interpret-ast body new-ctx))
+                               (recur (first clauses) (rest clauses)))
+                             (do
+                               (vswap! new-ctx #(merge % clause-ctx))
+                               (interpret-ast body new-ctx)))
                            (recur (first clauses) (rest clauses))))
 
                        (throw (ex-info (str "Match Error: No match found in loop for " input) {:ast ast}))))]
         (if (::data/recur output)
-          (recur (:tuple output))
+          (recur (:args output))
           output)))))
 
 (defn- panic [ast ctx]
@@ -633,6 +683,8 @@
 
 (defn- interpret-literal [ast] (-> ast :data first))
 
+(interpret-literal {:data [false]})
+
 (defn interpret-ast [ast ctx]
   (println "interpreting ast type" (:type ast))
   ;(println "AST: " ast)
@@ -652,11 +704,11 @@
 
     :cond (interpret-cond ast ctx)
 
-    ::ast/fn (interpret-fn ast ctx)
+    :fn (interpret-fn ast ctx)
 
-    ::ast/pipeline (interpret-do ast ctx)
+    :do (interpret-do ast ctx)
 
-    ::ast/placeholder ::data/placeholder
+    :placeholder ::data/placeholder
 
     ::ast/ns (interpret-ns ast ctx)
 
@@ -664,21 +716,19 @@
 
     ::ast/ref (interpret-ref ast ctx)
 
-    ::ast/panic (panic ast ctx)
-
     ::ast/spawn (interpret-spawn ast ctx)
 
     ::ast/send (interpret-send ast ctx)
 
     ::ast/receive (interpret-receive ast ctx)
 
-    ::ast/recur
+    :recur
-    {::data/recur true :tuple (interpret-ast (:tuple ast) ctx)}
+    {::data/recur true :args (interpret-ast (-> ast :data first) ctx)}
 
-    ::ast/loop (interpret-loop ast ctx)
+    :loop (interpret-loop ast ctx)
 
     :block
-    (let [exprs (:exprs ast)
+    (let [exprs (:data ast)
           inner (pop exprs)
           last (peek exprs)
           ctx (volatile! {::parent ctx})]
@@ -695,7 +745,7 @@
     ;; note that, excepting tuples and structs,
     ;; runtime representations are bare
     ;; tuples are vectors with a special first member
-    :tuple
+    (:tuple :args)
     (let [members (:data ast)]
       (into [::data/tuple] (map #(interpret-ast % ctx)) members))
 
@@ -785,7 +835,13 @@
 (do
   (process/start-vm)
   (def source "
-    id (1)
+    loop (4) with {
+      (0) -> print (:done)
+      (x) -> {
+        print (x)
+        recur (dec (x))
+      }
+    }
       ")
 
   (println "")
@@ -798,11 +854,14 @@
                  :tokens
                  (p/apply-parser g/script)
                  interpret-safe
-                 ;(show/show)
+                 show/show
                  )]
     (println result)
     result))
 
+
+(show/show false)
+
 (comment "
 
 	Left to do:

src/ludus/interpreter_new.clj

@@ -5,9 +5,8 @@
   		[ludus.scanner :as s]))
 
 (def source 
-  "
+  "fn () -> {recur (x)}
-foo (1, _)
+"
-  "
   )
 
 (def tokens (-> source s/scan :tokens))
@@ -37,5 +36,3 @@ foo (1, _)
               	clean 	
               	tap	
               	))
-
-(println my-data)

src/ludus/parser_new.clj

@@ -7,7 +7,7 @@
 
 (def failing #{:err :none})
 
-(def passing #{:ok :group :silent})
+(def passing #{:ok :group :quiet})
 
 (defn pass? [{status :status}] (contains? passing status))
 
@@ -32,7 +32,7 @@
   		(if (= kw (:type token))
    			{:status :ok 
    				:type kw 
-   				:data (if (value token) [(value token)] [])
+   				:data (if (some? (value token)) [(value token)] [])
    				:token token 
    				:remaining (rest tokens)}
    			{:status :none :token token :trace [kw] :remaining (rest tokens)})))
@@ -78,7 +78,7 @@
              				first-result (apply-parser (first parsers) tokens)]
           			(case (:status first-result)
            				(:err :none)
-           				(update (assoc first-result :trace #(conj % name)) :status :none)
+           				(assoc (update first-result :trace #(conj % name)) :status :none)
 
            				(:ok :quiet :group)
             			(loop [ps (rest parsers) 
@@ -164,7 +164,9 @@
                 					:quiet 	(recur (rest ps) results res-rem)
 
                 					(:err :none)
-                					(assoc (update result :trace #(conj % name)) :status :err)))))))})
+                					(assoc (update result :trace #(conj % name)) :status :err)
+
+                					(throw (ex-info (str "Got bad result: " (:status result)) result))))))))})
 
 (defn weak-order [name parsers]
  	{:name name

src/ludus/prelude.clj

@@ -98,7 +98,45 @@
            ::data/type ::data/clj
            :body d/ludus-draw})
 
+(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/type value) (case (::data/type value)
+                              (::data/fn ::data/clj) :fn
+                              ::data/ns :ns)
+        (::data/dict value) :dict
+        (::data/struct value) :struct
+
+        :else :none
+        ))))
+
+(def type- {:name "type"
+            ::data/type ::data/clj
+            :body get-type})
+
 (def prelude {
+              "id" id
               "foo" :foo
               "bar" :bar
               "eq" eq
@@ -120,4 +158,5 @@
               "conj" conj-
               "get" get-
               "draw" draw
+              "type" type
               })

src/ludus/show.clj

@@ -58,5 +58,3 @@
 (def show-keyed (comp
                   (map #(str (show (first %)) " " (show (second %))))
                   (interpose ", ")))
-
-(show {::data/type ::data/fn :name "foo"})