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

This commit is contained in:
Scott Richmond 2023-05-21 23:58:54 -04:00
parent 8516f0e053
commit b504370d96
7 changed files with 280 additions and 185 deletions

View File

@ -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)
") ")

View File

@ -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]))

View File

@ -57,23 +57,27 @@
))))))) )))))))
(defn- match-tuple [pattern value ctx-vol] (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 (cond
(not (vector? value)) {:success false :reason "Could not match non-tuple value to tuple"} (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)]
@ -81,7 +85,7 @@
(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
(if constraint
(if (interpret-ast constraint (volatile! clause-ctx))
(do (do
(vswap! new-ctx #(merge % clause-ctx)) (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))) (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,10 +297,24 @@
(interpret-ast body ctx) (interpret-ast body ctx)
(recur (first clauses) (rest clauses)))))))) (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] (defn- interpret-called-kw [kw tuple ctx]
(let [members (:data tuple)
length (count members)]
;; TODO: check this statically ;; 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) (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)
@ -335,44 +323,62 @@
(if (= (::data/type map) ::data/ns) (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 "Namespace error: no member " kw " in ns " (::data/name map)) {:ast kw}))
(throw (ex-info (str "Struct error: no member at " kw) {: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 (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
(if constraint
(if (do
;(println "######### Testing constraint")
;(println "Context: " clause-ctx)
(interpret-ast constraint vclause))
(do (do
;(println "passed constraint")
(vswap! fn-ctx #(merge % clause-ctx)) (vswap! fn-ctx #(merge % clause-ctx))
(interpret-ast body fn-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)
(defn- partial? [args]
(some #(= :placeholder (:type %)) args))
(defn- interpret-args [ast ctx]
(let [members (:data ast)]
(if (partial? args) (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] (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
(if constraint
(if (interpret-ast constraint (volatile! (assoc clause-ctx ::parent ctx)))
(do (do
(vswap! new-ctx #(merge % clause-ctx)) (vswap! new-ctx #(merge % clause-ctx))
(interpret-ast body 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)))) (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:

View File

@ -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)

View File

@ -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

View File

@ -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
}) })

View File

@ -58,5 +58,3 @@
(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"})