Interpret ns
This commit is contained in:
Scott Richmond
parent
9eecce77bc
commit
be2d291fd3
|
|
@ -33,14 +33,14 @@
|
||||||
(= 0 (:length pattern) (dec (count value))) {:success true :ctx {}}
|
(= 0 (:length pattern) (dec (count value))) {:success true :ctx {}}
|
||||||
|
|
||||||
:else (let [members (:members pattern)]
|
:else (let [members (:members pattern)]
|
||||||
(loop [i (:length pattern)
|
(loop [i (:length pattern)
|
||||||
ctx {}]
|
ctx {}]
|
||||||
(if (= 0 i)
|
(if (= 0 i)
|
||||||
{:success true :ctx ctx}
|
{:success true :ctx ctx}
|
||||||
(let [match? (match (nth members (dec i)) (nth value i) ctx-atom)]
|
(let [match? (match (nth members (dec i)) (nth value i) ctx-atom)]
|
||||||
(if (:success match?)
|
(if (:success match?)
|
||||||
(recur (dec i) (merge ctx (:ctx match?)))
|
(recur (dec i) (merge ctx (:ctx match?)))
|
||||||
{:success false :reason (str "Could not match " pattern " with " value)})))))))
|
{:success false :reason (str "Could not match " pattern " with " value)})))))))
|
||||||
|
|
||||||
(defn- match [pattern value ctx-atom]
|
(defn- match [pattern value ctx-atom]
|
||||||
(let [ctx @ctx-atom]
|
(let [ctx @ctx-atom]
|
||||||
|
|
@ -71,10 +71,10 @@
|
||||||
;; TODO: get typed exceptions to distinguish panics
|
;; TODO: get typed exceptions to distinguish panics
|
||||||
(defn- interpret-let [ast ctx]
|
(defn- interpret-let [ast ctx]
|
||||||
(let [pattern (:pattern ast)
|
(let [pattern (:pattern ast)
|
||||||
expr (:expr ast)
|
expr (:expr ast)
|
||||||
value (interpret-ast expr ctx)
|
value (interpret-ast expr ctx)
|
||||||
match (match pattern value ctx)
|
match (match pattern value ctx)
|
||||||
success (:success match)]
|
success (:success match)]
|
||||||
(if success
|
(if success
|
||||||
(swap! ctx update-ctx (:ctx match))
|
(swap! ctx update-ctx (:ctx match))
|
||||||
(throw (ex-info (:reason match) {})))
|
(throw (ex-info (:reason match) {})))
|
||||||
|
|
@ -82,32 +82,32 @@
|
||||||
|
|
||||||
(defn- interpret-if [ast ctx]
|
(defn- interpret-if [ast ctx]
|
||||||
(let [if-expr (:if ast)
|
(let [if-expr (:if ast)
|
||||||
then-expr (:then ast)
|
then-expr (:then ast)
|
||||||
else-expr (:else ast)
|
else-expr (:else ast)
|
||||||
if-value (interpret-ast if-expr ctx)]
|
if-value (interpret-ast if-expr ctx)]
|
||||||
(if if-value
|
(if if-value
|
||||||
(interpret-ast then-expr ctx)
|
(interpret-ast then-expr ctx)
|
||||||
(interpret-ast else-expr ctx))))
|
(interpret-ast else-expr ctx))))
|
||||||
|
|
||||||
(defn- interpret-match [ast ctx]
|
(defn- interpret-match [ast ctx]
|
||||||
(let [match-expr (:expr ast)
|
(let [match-expr (:expr ast)
|
||||||
expr (interpret-ast match-expr ctx)
|
expr (interpret-ast match-expr ctx)
|
||||||
clauses (:clauses ast)]
|
clauses (:clauses ast)]
|
||||||
(loop [clause (first clauses)
|
(loop [clause (first clauses)
|
||||||
clauses (rest clauses)]
|
clauses (rest clauses)]
|
||||||
(if clause
|
(if clause
|
||||||
(let [pattern (:pattern clause)
|
(let [pattern (:pattern clause)
|
||||||
body (:body clause)
|
body (:body clause)
|
||||||
new-ctx (atom {::parent ctx})
|
new-ctx (atom {::parent ctx})
|
||||||
match? (match pattern expr new-ctx)
|
match? (match pattern expr new-ctx)
|
||||||
success (:success match?)
|
success (:success match?)
|
||||||
clause-ctx (:ctx match?)]
|
clause-ctx (:ctx match?)]
|
||||||
(if success
|
(if success
|
||||||
(do
|
(do
|
||||||
(swap! new-ctx #(merge % clause-ctx))
|
(swap! 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" {}))))))
|
(throw (ex-info "Match Error: No match found" {}))))))
|
||||||
|
|
||||||
(defn- interpret-cond [ast ctx]
|
(defn- interpret-cond [ast ctx]
|
||||||
(let [clauses (:clauses ast)]
|
(let [clauses (:clauses ast)]
|
||||||
|
|
@ -131,7 +131,7 @@
|
||||||
(if (not (= 1 (:length tuple)))
|
(if (not (= 1 (:length tuple)))
|
||||||
(throw (ex-info "Called keywords must be unary" {}))
|
(throw (ex-info "Called keywords must be unary" {}))
|
||||||
(let [kw (interpret-ast kw ctx)
|
(let [kw (interpret-ast kw ctx)
|
||||||
map (second (interpret-ast tuple ctx))]
|
map (second (interpret-ast tuple ctx))]
|
||||||
(if (::data/struct map)
|
(if (::data/struct map)
|
||||||
(if (contains? map kw)
|
(if (contains? map kw)
|
||||||
(kw map)
|
(kw map)
|
||||||
|
|
@ -143,45 +143,45 @@
|
||||||
(cond
|
(cond
|
||||||
(= ::data/partial (first tuple))
|
(= ::data/partial (first tuple))
|
||||||
{::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 tuple)))
|
||||||
ctx))}
|
ctx))}
|
||||||
|
|
||||||
(= (::data/type lfn) ::data/clj) (apply (:body lfn) (next tuple))
|
(= (::data/type lfn) ::data/clj) (apply (:body lfn) (next tuple))
|
||||||
|
|
||||||
(= (::data/type lfn) ::data/fn)
|
(= (::data/type lfn) ::data/fn)
|
||||||
(let [clauses (:clauses lfn)]
|
(let [clauses (:clauses lfn)]
|
||||||
(loop [clause (first clauses)
|
(loop [clause (first clauses)
|
||||||
clauses (rest clauses)]
|
clauses (rest clauses)]
|
||||||
(if clause
|
(if clause
|
||||||
(let [pattern (:pattern clause)
|
(let [pattern (:pattern clause)
|
||||||
body (:body clause)
|
body (:body clause)
|
||||||
new-ctx (atom {::parent ctx})
|
new-ctx (atom {::parent ctx})
|
||||||
match? (match pattern tuple new-ctx)
|
match? (match pattern tuple new-ctx)
|
||||||
success (:success match?)
|
success (:success match?)
|
||||||
clause-ctx (:ctx match?)]
|
clause-ctx (:ctx match?)]
|
||||||
(if success
|
(if success
|
||||||
(do
|
(do
|
||||||
(swap! new-ctx #(merge % clause-ctx))
|
(swap! 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" {:fn-name (:name lfn)})))))
|
(throw (ex-info "Match Error: No match found" {:fn-name (:name lfn)})))))
|
||||||
|
|
||||||
(= clojure.lang.Keyword (type lfn))
|
(= clojure.lang.Keyword (type lfn))
|
||||||
(if (= 2 (count tuple))
|
(if (= 2 (count tuple))
|
||||||
(let [target (second tuple) kw lfn]
|
(let [target (second tuple) kw lfn]
|
||||||
(if (::data/struct target)
|
(if (::data/struct target)
|
||||||
(if (contains? target kw)
|
(if (contains? target kw)
|
||||||
(kw target)
|
(kw target)
|
||||||
(throw (ex-info (str "Struct error: no member at " kw) {})))
|
(throw (ex-info (str "Struct error: no member at " kw) {})))
|
||||||
(kw target)))
|
(kw target)))
|
||||||
(throw (ex-info "Called keywords take a single argument" {})))
|
(throw (ex-info "Called keywords take a single argument" {})))
|
||||||
|
|
||||||
:else (throw (ex-info "I don't know how to call that" {:fn lfn}))))
|
:else (throw (ex-info "I don't know how to call that" {:fn lfn}))))
|
||||||
|
|
||||||
;; TODO: add placeholder partial application
|
;; TODO: add placeholder partial application
|
||||||
(defn- interpret-synthetic-term [prev-value curr ctx]
|
(defn- interpret-synthetic-term [prev-value curr ctx]
|
||||||
|
|
@ -196,25 +196,25 @@
|
||||||
|
|
||||||
(defn- interpret-synthetic [ast ctx]
|
(defn- interpret-synthetic [ast ctx]
|
||||||
(let [terms (:terms ast)
|
(let [terms (:terms ast)
|
||||||
first (first terms)
|
first (first terms)
|
||||||
second (second terms)
|
second (second terms)
|
||||||
rest (rest (rest terms))
|
rest (rest (rest terms))
|
||||||
first-term-type (::ast/type first)
|
first-term-type (::ast/type first)
|
||||||
first-val (if (= first-term-type ::ast/atom)
|
first-val (if (= first-term-type ::ast/atom)
|
||||||
(interpret-called-kw first second ctx)
|
(interpret-called-kw first second ctx)
|
||||||
(interpret-synthetic-term (interpret-ast first ctx) second ctx))]
|
(interpret-synthetic-term (interpret-ast first ctx) second ctx))]
|
||||||
(reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest)))
|
(reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest)))
|
||||||
|
|
||||||
(defn- interpret-fn [ast ctx]
|
(defn- interpret-fn [ast ctx]
|
||||||
(let [name (:name ast)
|
(let [name (:name ast)
|
||||||
clauses (:clauses ast)]
|
clauses (:clauses ast)]
|
||||||
(if (= name ::ast/anon)
|
(if (= name ::ast/anon)
|
||||||
{::data/type ::data/fn
|
{::data/type ::data/fn
|
||||||
:name name
|
:name name
|
||||||
:clauses clauses}
|
:clauses clauses}
|
||||||
(let [fn {::data/type ::data/fn
|
(let [fn {::data/type ::data/fn
|
||||||
:name name
|
:name name
|
||||||
:clauses clauses}]
|
:clauses clauses}]
|
||||||
(if (contains? @ctx name)
|
(if (contains? @ctx name)
|
||||||
(throw (ex-info (str "Name " name " is already bound") {}))
|
(throw (ex-info (str "Name " name " is already bound") {}))
|
||||||
(do
|
(do
|
||||||
|
|
@ -223,21 +223,34 @@
|
||||||
|
|
||||||
(defn- interpret-do [ast ctx]
|
(defn- interpret-do [ast ctx]
|
||||||
(let [exprs (:exprs ast)
|
(let [exprs (:exprs ast)
|
||||||
origin (interpret-ast (first exprs) ctx)
|
origin (interpret-ast (first exprs) ctx)
|
||||||
fns (rest exprs)]
|
fns (rest exprs)]
|
||||||
(reduce #(call-fn (interpret-ast %2 ctx) [::data/tuple %1] ctx) origin fns)))
|
(reduce #(call-fn (interpret-ast %2 ctx) [::data/tuple %1] ctx) origin fns)))
|
||||||
|
|
||||||
(defn- map-values [f]
|
(defn- map-values [f]
|
||||||
(map (fn [kv]
|
(map (fn [kv]
|
||||||
(let [[k v] kv]
|
(let [[k v] kv]
|
||||||
[k (f v)]))))
|
[k (f v)]))))
|
||||||
|
|
||||||
|
(defn- interpret-ns [ast ctx]
|
||||||
|
(let [members (:members ast)
|
||||||
|
name (:name ast)]
|
||||||
|
(if (contains? @ctx name)
|
||||||
|
(throw (ex-info (str "ns name " name "is already bound") {}))
|
||||||
|
(let [ns (into
|
||||||
|
{::data/struct true ::data/type ::data/ns ::data/name name}
|
||||||
|
(map-values #(interpret-ast % ctx))
|
||||||
|
members)]
|
||||||
|
(do
|
||||||
|
(swap! ctx update-ctx {name ns})
|
||||||
|
ns)))))
|
||||||
|
|
||||||
(defn interpret-ast [ast ctx]
|
(defn interpret-ast [ast ctx]
|
||||||
(case (::ast/type ast)
|
(case (::ast/type ast)
|
||||||
|
|
||||||
::ast/atom (:value ast)
|
::ast/atom (:value ast)
|
||||||
|
|
||||||
::ast/word (resolve-word(:word ast) ctx)
|
::ast/word (resolve-word (:word ast) ctx)
|
||||||
|
|
||||||
::ast/let (interpret-let ast ctx)
|
::ast/let (interpret-let ast ctx)
|
||||||
|
|
||||||
|
|
@ -255,19 +268,21 @@
|
||||||
|
|
||||||
::ast/placeholder ::data/placeholder
|
::ast/placeholder ::data/placeholder
|
||||||
|
|
||||||
|
::ast/ns (interpret-ns ast ctx)
|
||||||
|
|
||||||
::ast/block
|
::ast/block
|
||||||
(let [exprs (:exprs ast)
|
(let [exprs (:exprs ast)
|
||||||
inner (pop exprs)
|
inner (pop exprs)
|
||||||
last (peek exprs)
|
last (peek exprs)
|
||||||
ctx (atom {::parent ctx})]
|
ctx (atom {::parent ctx})]
|
||||||
(run! #(interpret-ast % ctx) inner)
|
(run! #(interpret-ast % ctx) inner)
|
||||||
(interpret-ast last ctx))
|
(interpret-ast last ctx))
|
||||||
|
|
||||||
::ast/script
|
::ast/script
|
||||||
(let [exprs (:exprs ast)
|
(let [exprs (:exprs ast)
|
||||||
inner (pop exprs)
|
inner (pop exprs)
|
||||||
last (peek exprs)
|
last (peek exprs)
|
||||||
ctx (atom prelude/prelude)]
|
ctx (atom prelude/prelude)]
|
||||||
(run! #(interpret-ast % ctx) inner)
|
(run! #(interpret-ast % ctx) inner)
|
||||||
(interpret-ast last ctx))
|
(interpret-ast last ctx))
|
||||||
|
|
||||||
|
|
@ -313,7 +328,13 @@
|
||||||
else -> :oops
|
else -> :oops
|
||||||
}
|
}
|
||||||
|
|
||||||
")
|
ns bar {
|
||||||
|
foo
|
||||||
|
}
|
||||||
|
|
||||||
|
bar :foo
|
||||||
|
|
||||||
|
")
|
||||||
|
|
||||||
(println "")
|
(println "")
|
||||||
(println "****************************************")
|
(println "****************************************")
|
||||||
|
|
@ -335,7 +356,7 @@
|
||||||
* refactor calling keywords
|
* refactor calling keywords
|
||||||
* refactor accessing structs vs. hashes
|
* refactor accessing structs vs. hashes
|
||||||
|
|
||||||
")
|
")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user