Keep knocking 'em down: fns, loops, pipelines work
This commit is contained in:
parent
8516f0e053
commit
b504370d96
|
@ -16,11 +16,11 @@
|
||||||
What sorts of compiling and validation do we want to do? Be specific.
|
What sorts of compiling and validation do we want to do? Be specific.
|
||||||
|
|
||||||
- check used names are bound (validation)
|
- 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)
|
- 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)
|
- flag tail calls for optimization (optimization)
|
||||||
- direct tail calls
|
- direct tail calls
|
||||||
- through different expressions
|
- through different expressions
|
||||||
|
@ -29,6 +29,6 @@
|
||||||
- cond
|
- cond
|
||||||
- match
|
- match
|
||||||
- let
|
- let
|
||||||
- check ns access
|
- check ns access (validation)
|
||||||
|
|
||||||
")
|
")
|
|
@ -163,7 +163,7 @@
|
||||||
|
|
||||||
(def synthetic (group (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])))
|
(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]))
|
(def fn-entry (order-1 :fn-entry [fn-clause terminators]))
|
||||||
|
|
||||||
|
|
|
@ -57,31 +57,35 @@
|
||||||
)))))))
|
)))))))
|
||||||
|
|
||||||
(defn- match-tuple [pattern value ctx-vol]
|
(defn- match-tuple [pattern value ctx-vol]
|
||||||
(cond
|
;(println "\n\n\n**********Matching tuple")
|
||||||
(not (vector? value)) {:success false :reason "Could not match non-tuple value to 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"}
|
(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)
|
(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"}
|
{: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
|
: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)
|
||||||
(if (= 0 i)
|
{:success true :ctx @ctx-diff}
|
||||||
{:success true :ctx @ctx-diff}
|
(let [match? (match (nth members (dec i)) (nth value i) ctx-diff)]
|
||||||
(let [match? (match (nth members (dec 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-list [pattern value ctx-vol]
|
(defn- match-list [pattern value ctx-vol]
|
||||||
(cond
|
(cond
|
||||||
|
@ -128,7 +132,7 @@
|
||||||
(let [match? (match (kw members) (kw value) ctx-diff)]
|
(let [match? (match (kw members) (kw value) ctx-diff)]
|
||||||
(if (:success match?)
|
(if (:success match?)
|
||||||
(do
|
(do
|
||||||
(println (:ctx match?))
|
;(println (:ctx match?))
|
||||||
(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 " at key " kw " because " (:reason match?))}))
|
{: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 " (:reason match?))}))
|
||||||
{:success false :reason (str "Could not match " pattern " with " value " at key " kw ", because there is no value at " kw)})))))))
|
{: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]
|
(defn- match-typed [pattern value ctx]
|
||||||
(let [data (:data pattern)
|
(let [data (:data pattern)
|
||||||
name (-> data first :data)
|
name (-> data first :data)
|
||||||
type (-> data second :data)]
|
type (-> data second :data)]
|
||||||
(cond
|
(cond
|
||||||
(contains? ctx name) {:success false :reason (str "Name " name "is already bound") :code :name-error}
|
(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}})))
|
:else {:success true :ctx {name value}})))
|
||||||
|
|
||||||
(defn- match [pattern value ctx-vol]
|
(defn- match [pattern value ctx-vol]
|
||||||
|
;(println "Matching " value " with pattern type " (:type pattern))
|
||||||
(let [ctx @ctx-vol]
|
(let [ctx @ctx-vol]
|
||||||
(case (:type pattern)
|
(case (:type pattern)
|
||||||
(:placeholder :ignored)
|
(:placeholder :ignored)
|
||||||
|
@ -223,15 +195,15 @@
|
||||||
|
|
||||||
:typed (match-typed pattern value ctx)
|
: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]
|
(defn- update-ctx [ctx new-ctx]
|
||||||
(merge ctx new-ctx))
|
(merge ctx new-ctx))
|
||||||
|
@ -295,12 +267,14 @@
|
||||||
success (:success match?)
|
success (:success match?)
|
||||||
clause-ctx (:ctx match?)]
|
clause-ctx (:ctx match?)]
|
||||||
(if success
|
(if success
|
||||||
(do
|
(if constraint
|
||||||
(vswap! new-ctx #(merge % clause-ctx))
|
(if (interpret-ast constraint (volatile! clause-ctx))
|
||||||
(if constraint
|
(do
|
||||||
(if (interpret-ast constraint new-ctx)
|
(vswap! new-ctx #(merge % clause-ctx))
|
||||||
(interpret-ast body new-ctx)
|
(interpret-ast body new-ctx))
|
||||||
(recur (first clauses) (rest clauses)))
|
(recur (first clauses) (rest clauses)))
|
||||||
|
(do
|
||||||
|
(vswap! new-ctx #(merge % clause-ctx))
|
||||||
(interpret-ast body new-ctx)))
|
(interpret-ast body new-ctx)))
|
||||||
(recur (first clauses) (rest clauses))))
|
(recur (first clauses) (rest clauses))))
|
||||||
(throw (ex-info "Match Error: No match found" {:ast ast}))))))
|
(throw (ex-info "Match Error: No match found" {:ast ast}))))))
|
||||||
|
@ -323,56 +297,88 @@
|
||||||
(interpret-ast body ctx)
|
(interpret-ast body ctx)
|
||||||
(recur (first clauses) (rest clauses))))))))
|
(recur (first clauses) (rest clauses))))))))
|
||||||
|
|
||||||
(defn- interpret-called-kw [kw tuple ctx]
|
(defn- validate-args [args]
|
||||||
;; TODO: check this statically
|
(>= 1 (count (filter #(= :placeholder (:type %)) args))))
|
||||||
(if (not (= 1 (:length tuple)))
|
|
||||||
(throw (ex-info "Called keywords must be unary" {:ast kw}))
|
|
||||||
(let [kw (interpret-ast kw ctx)
|
|
||||||
map (second (interpret-ast tuple ctx))]
|
|
||||||
(if (::data/struct map)
|
|
||||||
(if (contains? map kw)
|
|
||||||
(kw map)
|
|
||||||
(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)))))
|
|
||||||
|
|
||||||
(defn- call-fn [lfn tuple ctx]
|
(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
|
||||||
|
(cond
|
||||||
|
(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)
|
||||||
|
(if (contains? map kw)
|
||||||
|
(kw map)
|
||||||
|
(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))))))
|
||||||
|
|
||||||
|
(defn- call-fn [lfn args ctx]
|
||||||
(cond
|
(cond
|
||||||
(= ::data/partial (first tuple))
|
(= ::data/partial (first args))
|
||||||
{::data/type ::data/clj
|
{::data/type ::data/clj
|
||||||
:name (str (:name lfn) "{partial}")
|
:name (str (:name lfn) "{partial}")
|
||||||
:body (fn [arg]
|
:body (fn [arg]
|
||||||
(call-fn
|
(call-fn
|
||||||
lfn
|
lfn
|
||||||
(concat [::data/tuple] (replace {::data/placeholder arg} (rest tuple)))
|
(concat [::data/tuple] (replace {::data/placeholder arg} (rest args)))
|
||||||
ctx))}
|
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)
|
(= (::data/type lfn) ::data/fn)
|
||||||
(let [clauses (:clauses lfn)
|
(let [clauses (:clauses lfn)
|
||||||
closed-over (:ctx lfn)]
|
closed-over (:ctx lfn)]
|
||||||
(loop [clause (first clauses)
|
(loop [clause (first clauses)
|
||||||
clauses (rest clauses)]
|
clauses (rest clauses)]
|
||||||
|
;(println "Matching clause " clause)
|
||||||
|
;(println "With args " args)
|
||||||
(if clause
|
(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})
|
fn-ctx (volatile! {::parent closed-over})
|
||||||
match? (match pattern tuple fn-ctx)
|
match? (match pattern args fn-ctx)
|
||||||
success (:success match?)
|
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 success
|
||||||
(do
|
(if constraint
|
||||||
(vswap! fn-ctx #(merge % clause-ctx))
|
(if (do
|
||||||
(interpret-ast body fn-ctx))
|
;(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))))
|
(recur (first clauses) (rest clauses))))
|
||||||
|
|
||||||
(throw (ex-info "Match Error: No match found" {:ast (:ast lfn)})))))
|
(throw (ex-info "Match Error: No match found" {:ast (:ast lfn)})))))
|
||||||
|
|
||||||
(keyword? 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 (::data/struct target)
|
||||||
(if (contains? target kw)
|
(if (contains? target kw)
|
||||||
(kw target)
|
(kw target)
|
||||||
|
@ -385,24 +391,20 @@
|
||||||
|
|
||||||
:else (throw (ex-info "I don't know how to call that" {:ast lfn}))))
|
: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)
|
||||||
|
(if (partial? args)
|
||||||
(defn- partial? [args]
|
(if (validate-args args)
|
||||||
(some #(= :placeholder (:type %)) args))
|
(into [::data/partial] (map #(interpret-ast % ctx)) args) ; do the thing
|
||||||
|
(throw (ex-info "Partially applied functions may only take a single argument" {:ast args})))
|
||||||
(defn- interpret-args [ast ctx]
|
(into [::data/tuple] (map #(interpret-ast % ctx)) args))
|
||||||
(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]
|
(defn- interpret-synthetic-term [prev-value curr ctx]
|
||||||
(let [type (:type curr)
|
(let [type (:type curr)
|
||||||
data (:data curr)]
|
data (:data curr)]
|
||||||
|
;(println "interpreting synthetic type " type)
|
||||||
|
;(println "interpreting synthetic node " curr)
|
||||||
(if (= type :keyword)
|
(if (= type :keyword)
|
||||||
(if (::data/struct prev-value)
|
(if (::data/struct prev-value)
|
||||||
(if (contains? prev-value (first data))
|
(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 "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}))))
|
(throw (ex-info (str "Struct error: no member " (:value curr)) {:ast curr}))))
|
||||||
(get prev-value (first data)))
|
(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]
|
(defn- interpret-synthetic [ast ctx]
|
||||||
|
;;(println "interpreting synthetic " ast)
|
||||||
(let [data (:data 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
|
(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)
|
(let [name (:name ast)
|
||||||
clauses (:clauses ast)]
|
clauses (:clauses ast)]
|
||||||
(if (= name ::ast/anon)
|
(if (= name ::ast/anon)
|
||||||
|
@ -447,11 +451,44 @@
|
||||||
(vswap! ctx update-ctx {name fn})
|
(vswap! ctx update-ctx {name fn})
|
||||||
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]
|
(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]
|
(defn- map-values [f]
|
||||||
(map (fn [kv]
|
(map (fn [kv]
|
||||||
|
@ -501,27 +538,40 @@
|
||||||
ref)))
|
ref)))
|
||||||
|
|
||||||
(defn- interpret-loop [ast ctx]
|
(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]
|
(loop [input tuple]
|
||||||
(let [output (loop [clause (first clauses)
|
(let [output (loop [clause (first clauses)
|
||||||
clauses (rest clauses)]
|
clauses (rest clauses)]
|
||||||
(if clause
|
(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})
|
new-ctx (volatile! {::parent ctx})
|
||||||
match? (match pattern input new-ctx)
|
match? (match pattern input new-ctx)
|
||||||
success (:success match?)
|
success (:success match?)
|
||||||
clause-ctx (:ctx match?)]
|
clause-ctx (:ctx match?)]
|
||||||
(if success
|
(if success
|
||||||
(do
|
(if constraint
|
||||||
(vswap! new-ctx #(merge % clause-ctx))
|
(if (interpret-ast constraint (volatile! (assoc clause-ctx ::parent ctx)))
|
||||||
(interpret-ast body new-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))))
|
(recur (first clauses) (rest clauses))))
|
||||||
|
|
||||||
(throw (ex-info (str "Match Error: No match found in loop for " input) {:ast ast}))))]
|
(throw (ex-info (str "Match Error: No match found in loop for " input) {:ast ast}))))]
|
||||||
(if (::data/recur output)
|
(if (::data/recur output)
|
||||||
(recur (:tuple output))
|
(recur (:args output))
|
||||||
output)))))
|
output)))))
|
||||||
|
|
||||||
(defn- panic [ast ctx]
|
(defn- panic [ast ctx]
|
||||||
|
@ -633,6 +683,8 @@
|
||||||
|
|
||||||
(defn- interpret-literal [ast] (-> ast :data first))
|
(defn- interpret-literal [ast] (-> ast :data first))
|
||||||
|
|
||||||
|
(interpret-literal {:data [false]})
|
||||||
|
|
||||||
(defn interpret-ast [ast ctx]
|
(defn interpret-ast [ast ctx]
|
||||||
(println "interpreting ast type" (:type ast))
|
(println "interpreting ast type" (:type ast))
|
||||||
;(println "AST: " ast)
|
;(println "AST: " ast)
|
||||||
|
@ -652,11 +704,11 @@
|
||||||
|
|
||||||
:cond (interpret-cond ast ctx)
|
: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)
|
::ast/ns (interpret-ns ast ctx)
|
||||||
|
|
||||||
|
@ -664,21 +716,19 @@
|
||||||
|
|
||||||
::ast/ref (interpret-ref ast ctx)
|
::ast/ref (interpret-ref ast ctx)
|
||||||
|
|
||||||
::ast/panic (panic ast ctx)
|
|
||||||
|
|
||||||
::ast/spawn (interpret-spawn ast ctx)
|
::ast/spawn (interpret-spawn ast ctx)
|
||||||
|
|
||||||
::ast/send (interpret-send ast ctx)
|
::ast/send (interpret-send ast ctx)
|
||||||
|
|
||||||
::ast/receive (interpret-receive 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
|
:block
|
||||||
(let [exprs (:exprs ast)
|
(let [exprs (:data ast)
|
||||||
inner (pop exprs)
|
inner (pop exprs)
|
||||||
last (peek exprs)
|
last (peek exprs)
|
||||||
ctx (volatile! {::parent ctx})]
|
ctx (volatile! {::parent ctx})]
|
||||||
|
@ -695,7 +745,7 @@
|
||||||
;; note that, excepting tuples and structs,
|
;; note that, excepting tuples and structs,
|
||||||
;; runtime representations are bare
|
;; runtime representations are bare
|
||||||
;; tuples are vectors with a special first member
|
;; tuples are vectors with a special first member
|
||||||
:tuple
|
(:tuple :args)
|
||||||
(let [members (:data ast)]
|
(let [members (:data ast)]
|
||||||
(into [::data/tuple] (map #(interpret-ast % ctx)) members))
|
(into [::data/tuple] (map #(interpret-ast % ctx)) members))
|
||||||
|
|
||||||
|
@ -785,7 +835,13 @@
|
||||||
(do
|
(do
|
||||||
(process/start-vm)
|
(process/start-vm)
|
||||||
(def source "
|
(def source "
|
||||||
id (1)
|
loop (4) with {
|
||||||
|
(0) -> print (:done)
|
||||||
|
(x) -> {
|
||||||
|
print (x)
|
||||||
|
recur (dec (x))
|
||||||
|
}
|
||||||
|
}
|
||||||
")
|
")
|
||||||
|
|
||||||
(println "")
|
(println "")
|
||||||
|
@ -798,11 +854,14 @@
|
||||||
:tokens
|
:tokens
|
||||||
(p/apply-parser g/script)
|
(p/apply-parser g/script)
|
||||||
interpret-safe
|
interpret-safe
|
||||||
;(show/show)
|
show/show
|
||||||
)]
|
)]
|
||||||
(println result)
|
(println result)
|
||||||
result))
|
result))
|
||||||
|
|
||||||
|
|
||||||
|
(show/show false)
|
||||||
|
|
||||||
(comment "
|
(comment "
|
||||||
|
|
||||||
Left to do:
|
Left to do:
|
||||||
|
|
|
@ -5,9 +5,8 @@
|
||||||
[ludus.scanner :as s]))
|
[ludus.scanner :as s]))
|
||||||
|
|
||||||
(def source
|
(def source
|
||||||
"
|
"fn () -> {recur (x)}
|
||||||
foo (1, _)
|
"
|
||||||
"
|
|
||||||
)
|
)
|
||||||
|
|
||||||
(def tokens (-> source s/scan :tokens))
|
(def tokens (-> source s/scan :tokens))
|
||||||
|
@ -37,5 +36,3 @@ foo (1, _)
|
||||||
clean
|
clean
|
||||||
tap
|
tap
|
||||||
))
|
))
|
||||||
|
|
||||||
(println my-data)
|
|
||||||
|
|
|
@ -7,7 +7,7 @@
|
||||||
|
|
||||||
(def failing #{:err :none})
|
(def failing #{:err :none})
|
||||||
|
|
||||||
(def passing #{:ok :group :silent})
|
(def passing #{:ok :group :quiet})
|
||||||
|
|
||||||
(defn pass? [{status :status}] (contains? passing status))
|
(defn pass? [{status :status}] (contains? passing status))
|
||||||
|
|
||||||
|
@ -32,7 +32,7 @@
|
||||||
(if (= kw (:type token))
|
(if (= kw (:type token))
|
||||||
{:status :ok
|
{:status :ok
|
||||||
:type kw
|
:type kw
|
||||||
:data (if (value token) [(value token)] [])
|
:data (if (some? (value token)) [(value token)] [])
|
||||||
:token token
|
:token token
|
||||||
:remaining (rest tokens)}
|
:remaining (rest tokens)}
|
||||||
{:status :none :token token :trace [kw] :remaining (rest tokens)})))
|
{:status :none :token token :trace [kw] :remaining (rest tokens)})))
|
||||||
|
@ -78,7 +78,7 @@
|
||||||
first-result (apply-parser (first parsers) tokens)]
|
first-result (apply-parser (first parsers) tokens)]
|
||||||
(case (:status first-result)
|
(case (:status first-result)
|
||||||
(:err :none)
|
(:err :none)
|
||||||
(update (assoc first-result :trace #(conj % name)) :status :none)
|
(assoc (update first-result :trace #(conj % name)) :status :none)
|
||||||
|
|
||||||
(:ok :quiet :group)
|
(:ok :quiet :group)
|
||||||
(loop [ps (rest parsers)
|
(loop [ps (rest parsers)
|
||||||
|
@ -164,7 +164,9 @@
|
||||||
:quiet (recur (rest ps) results res-rem)
|
:quiet (recur (rest ps) results res-rem)
|
||||||
|
|
||||||
(:err :none)
|
(: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]
|
(defn weak-order [name parsers]
|
||||||
{:name name
|
{:name name
|
||||||
|
|
|
@ -98,7 +98,45 @@
|
||||||
::data/type ::data/clj
|
::data/type ::data/clj
|
||||||
:body d/ludus-draw})
|
: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 {
|
(def prelude {
|
||||||
|
"id" id
|
||||||
"foo" :foo
|
"foo" :foo
|
||||||
"bar" :bar
|
"bar" :bar
|
||||||
"eq" eq
|
"eq" eq
|
||||||
|
@ -120,4 +158,5 @@
|
||||||
"conj" conj-
|
"conj" conj-
|
||||||
"get" get-
|
"get" get-
|
||||||
"draw" draw
|
"draw" draw
|
||||||
|
"type" type
|
||||||
})
|
})
|
|
@ -1,7 +1,7 @@
|
||||||
(ns ludus.show
|
(ns ludus.show
|
||||||
(:require
|
(:require
|
||||||
[ludus.data :as data]
|
[ludus.data :as data]
|
||||||
[clojure.pprint :as pp]))
|
[clojure.pprint :as pp]))
|
||||||
|
|
||||||
(declare show show-linear show-keyed)
|
(declare show show-linear show-keyed)
|
||||||
|
|
||||||
|
@ -13,13 +13,13 @@
|
||||||
(defn- show-map [v]
|
(defn- show-map [v]
|
||||||
(cond
|
(cond
|
||||||
(or (= (::data/type v) ::data/fn)
|
(or (= (::data/type v) ::data/fn)
|
||||||
(= (::data/type v) ::data/clj))
|
(= (::data/type v) ::data/clj))
|
||||||
(str "fn " (:name v))
|
(str "fn " (:name v))
|
||||||
|
|
||||||
(= (::data/type v) ::data/ns)
|
(= (::data/type v) ::data/ns)
|
||||||
(str "ns " (::data/name v) " {"
|
(str "ns " (::data/name v) " {"
|
||||||
(apply str (into [] show-keyed (dissoc v ::data/struct ::data/type ::data/name)))
|
(apply str (into [] show-keyed (dissoc v ::data/struct ::data/type ::data/name)))
|
||||||
"}")
|
"}")
|
||||||
|
|
||||||
(::data/struct v)
|
(::data/struct v)
|
||||||
(str "@{" (apply str (into [] show-keyed (dissoc v ::data/struct))) "}")
|
(str "@{" (apply str (into [] show-keyed (dissoc v ::data/struct))) "}")
|
||||||
|
@ -38,25 +38,23 @@
|
||||||
|
|
||||||
(defn show
|
(defn show
|
||||||
([v]
|
([v]
|
||||||
(cond
|
(cond
|
||||||
(string? v) (str "\"" v "\"")
|
(string? v) (str "\"" v "\"")
|
||||||
(number? v) (str v)
|
(number? v) (str v)
|
||||||
(keyword? v) (str v)
|
(keyword? v) (str v)
|
||||||
(boolean? v) (str v)
|
(boolean? v) (str v)
|
||||||
(nil? v) "nil"
|
(nil? v) "nil"
|
||||||
(vector? v) (show-vector v)
|
(vector? v) (show-vector v)
|
||||||
(set? v) (show-set v)
|
(set? v) (show-set v)
|
||||||
(map? v) (show-map v)
|
(map? v) (show-map v)
|
||||||
:else
|
:else
|
||||||
(with-out-str (pp/pprint v))
|
(with-out-str (pp/pprint v))
|
||||||
))
|
))
|
||||||
([v & vs] (apply str (into [] (comp (map show) (interpose " ")) (concat [v] vs))))
|
([v & vs] (apply str (into [] (comp (map show) (interpose " ")) (concat [v] vs))))
|
||||||
)
|
)
|
||||||
|
|
||||||
(def show-linear (comp (map show) (interpose ", ")))
|
(def show-linear (comp (map show) (interpose ", ")))
|
||||||
|
|
||||||
(def show-keyed (comp
|
(def show-keyed (comp
|
||||||
(map #(str (show (first %)) " " (show (second %))))
|
(map #(str (show (first %)) " " (show (second %))))
|
||||||
(interpose ", ")))
|
(interpose ", ")))
|
||||||
|
|
||||||
(show {::data/type ::data/fn :name "foo"})
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user