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,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:

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

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