twc/ludus
4
0
Fork 0
Code Issues 32 Pull Requests Packages Projects 8 Releases Wiki Activity

Get annoyed by translating my clj parser into janet; start work on a Janet/PEG parser

Browse Source
This commit is contained in:
Scott Richmond 2024-01-11 19:42:58 -05:00
parent f4d09afed6
commit f02532ee40
2 changed files with 160 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
janet/clj-loop.janet
View File

@ -2,7 +2,7 @@
``A drop-in replacement for Clojure's loop form. Useful for the current project of converting Clojure code to Janet. ``A drop-in replacement for Clojure's loop form. Useful for the current project of converting Clojure code to Janet.
`` ``
[bindings & body] [bindings & body]
(assert (even? (length bindings))) (assert (even? (length bindings)) "Binding tuple must have an even number of terms")
(def names @[]) (def names @[])
(def args @[]) (def args @[])
(loop [i :range [0 (length bindings)]] (loop [i :range [0 (length bindings)]]
@ -11,3 +11,39 @@
(array/push args (get bindings i)))) (array/push args (get bindings i))))
~(do (defn recur [,;names] ,;body) (recur ,;args))) ~(do (defn recur [,;names] ,;body) (recur ,;args)))
(defmacro defn+
[name & clauses]
~(defn ,name [& args]
(print "before do")
(do
(def arities @{})
(def clauses ,clauses)
(def bindingses (map first clauses))
(def bodies (map |(slice $ 1) clauses))
(print "before loop")
(loop [i :range [0 (length clauses)]]
(def bindings (get bindingses i))
(def arity (length bindings))
(assert (not (get arities i)) "Clauses must have different arities")
(def body (get bodies i))
(def clause ~(fn ,name ,bindings ,;body))
(put $arities arity clause))
(print "before quasiquote")
(fn [& args]
(def arity (length args))
(def clause (get arities arity))
(assert clause "No clause with that arity")
(clause ;args)))))
(defn+ add
([] 0)
([x] x)
([x y] (+ x y)))
(macex1
'(defn+ add
([] 0)
([x] x)
([x y] (+ x y))))

168
janet/parser.janet
View File

@ -38,12 +38,12 @@
(let [token (first tokens)] (let [token (first tokens)]
#(if (= kw (get token :type)) (println "Matched " kw)) #(if (= kw (get token :type)) (println "Matched " kw))
(if (= kw (get token :type)) (if (= kw (get token :type))
{:status :ok @{:status :ok
:type kw :type kw
:data (if (some? (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)})))
(defn apply-fn-parser [parser tokens] (defn apply-fn-parser [parser tokens]
(let [rule (get parser :rule) name (get parser :name) result (rule tokens)] (let [rule (get parser :rule) name (get parser :name) result (rule tokens)]
@ -65,7 +65,7 @@
(defn choice [name parsers] (defn choice [name parsers]
{:name name {:name name
:rule (fn choice-fn [tokens] :rule (fn choice-fn [tokens]
(defn recur [ps] (clj-loop [ps parsers]
(let [result (apply-parser (first ps) tokens) (let [result (apply-parser (first ps) tokens)
rem-ts (remaining result) rem-ts (remaining result)
rem-ps (rest ps)] rem-ps (rest ps)]
@ -79,9 +79,7 @@
(empty? rem-ps) (empty? rem-ps)
{:status :none :token (first tokens) :trace [name] :remaining rem-ts} {:status :none :token (first tokens) :trace [name] :remaining rem-ts}
:else (recur rem-ps)))) :else (recur rem-ps)))))})
(recur parsers))})
(defn order-1 [name parsers] (defn order-1 [name parsers]
{:name name {:name name
@ -98,19 +96,19 @@
res-rem (remaining result)] res-rem (remaining result)]
(if (empty? (rest ps)) (if (empty? (rest ps))
(case (get result :status) (case (get result :status)
:ok {:status :group :ok @{:status :group
:type name :type name
:data (array/push results result) :data (array/push results result)
:token origin :token origin
:remaining res-rem} :remaining res-rem}
:quiet {:status :group :quiet @{:status :group
:type name :type name
:data results :data results
:token origin :token origin
:remaining res-rem} :remaining res-rem}
:group {:status :group :group @{:status :group
:type name :type name
:data (array/concat results (get result :data)) :data (array/concat results (get result :data))
:token origin :token origin
@ -143,19 +141,19 @@
(if (empty? (rest ps)) (if (empty? (rest ps))
## Nothing more: return ## Nothing more: return
(case (get result :status) (case (get result :status)
:ok {:status :group :ok @{:status :group
:type name :type name
:data (array/push results result) :data (array/push results result)
:token origin :token origin
:remaining res-rem} :remaining res-rem}
:quiet {:status :group :quiet @{:status :group
:type name :type name
:data results :data results
:token origin :token origin
:remaining res-rem} :remaining res-rem}
:group {:status :group :group @{:status :group
:type name :type name
:data (array/concat results (get result :data)) :data (array/concat results (get result :data))
:token origin :token origin
@ -178,7 +176,6 @@
(error (string "Got bad result: " (get result :status))))))) (error (string "Got bad result: " (get result :status)))))))
(recur parsers [] tokens)))}) (recur parsers [] tokens)))})
#### Start here
(defn weak-order [name parsers] (defn weak-order [name parsers]
{:name name {:name name
:rule (fn order-fn [tokens] :rule (fn order-fn [tokens]
@ -191,19 +188,19 @@
(if (empty? (rest ps)) (if (empty? (rest ps))
## Nothing more: return ## Nothing more: return
(case (get result :status) (case (get result :status)
:ok {:status :group :ok @{:status :group
:type name :type name
:data (array/push results result) :data (array/push results result)
:token origin :token origin
:remaining res-rem} :remaining res-rem}
:quiet {:status :group :quiet @{:status :group
:type name :type name
:data results :data results
:token origin :token origin
:remaining res-rem} :remaining res-rem}
:group {:status :group :group @{:status :group
:type name :type name
:data (array/concat results (get result :data)) :data (array/concat results (get result :data))
:token origin :token origin
@ -231,12 +228,7 @@
(put result :status :quiet) (put result :status :quiet)
result)))}) result)))})
### Start here (defn zero+/2 [name parser]
### How to write variadic functions here that preserve this logic
### Janet doesn't allow for Clojure's multiple clauses, :(
(defn zero+
([parser] (zero+ (pname parser) parser))
([name parser]
{:name (kw+str name "-zero+") {:name (kw+str name "-zero+")
:rule (fn zero+fn [tokens] :rule (fn zero+fn [tokens]
(clj-loop [results [] (clj-loop [results []
@ -247,15 +239,37 @@
:group (recur (array/concat results (get result :data)) (remaining result)) :group (recur (array/concat results (get result :data)) (remaining result))
:quiet (recur results (remaining result)) :quiet (recur results (remaining result))
:err (update result :trace |(array/push $ name)) :err (update result :trace |(array/push $ name))
:none {:status :group :none @{:status :group
:type name :type name
:data results :data results
:token (first tokens) :token (first tokens)
:remaining ts}))))})) :remaining ts}))))})
(defn one+ (defn zero+/1 [parser] (zero+/2 (pname parser) parser))
([parser] (one+ (pname parser) parser))
([name parser] (defn zero+ [& args]
(def arity (length args))
(if (= 1 arity) (zero+/1 ;args) (zero+/2 ;args)))
# ([parser] (zero+ (pname parser) parser))
# ([name parser]
# {:name (kw+str name "-zero+")
# :rule (fn zero+fn [tokens]
# (clj-loop [results []
# ts tokens]
# (let [result (apply-parser parser ts)]
# (case (get result :status)
# :ok (recur (array/push results result) (remaining result))
# :group (recur (array/concat results (get result :data)) (remaining result))
# :quiet (recur results (remaining result))
# :err (update result :trace |(array/push $ name))
# :none {:status :group
# :type name
# :data results
# :token (first tokens)
# :remaining ts}))))}))
(defn one+/2 [name parser]
{:name (kw+str name "-one+") {:name (kw+str name "-one+")
:rule (fn one+fn [tokens] :rule (fn one+fn [tokens]
(let [first-result (apply-parser parser tokens) (let [first-result (apply-parser parser tokens)
@ -287,26 +301,88 @@
:token (first tokens) :token (first tokens)
:remaining (remaining rest-result)}) :remaining (remaining rest-result)})
(:err :none) first-result)))})) (:err :none) first-result)))})
(defn maybe (defn one+/1 [parser] (one+/2 (pname parser) parser))
([parser] (maybe (pname parser) parser))
([name parser]
{:name (kw+str name "-maybe")
:rule (fn maybe-fn [tokens]
(let [result (apply-parser parser tokens)]
(if (pass? result)
result
{:status :group :type name :data [] :token (first tokens) :remaining tokens}
)))}))
(defn flat (defn one+ [& args]
([parser] (flat (pname parser) parser)) (def arity (length args))
([name parser] (if (= 1 arity) (one+/1 ;args) (one+/2 ;args)))
{:name (kw+str name "-flat")
:rule (fn flat-fn [tokens] # (defn one+
(let [result (apply-parser parser tokens)] # ([parser] (one+ (pname parser) parser))
(if (pass? result) (first (get result :data)) result)))})) # ([name parser]
# {:name (kw+str name "-one+")
# :rule (fn one+fn [tokens]
# (let [first-result (apply-parser parser tokens)
# rest-parser (zero+ name parser)]
# (case (get first-result :status)
# (:ok :group)
# (let [rest-result (apply-parser rest-parser (remaining first-result))]
# (case (get rest-result :status)
# (:ok :group :quiet)
# {:status :group
# :type name
# :data (array/concat (get first-result :data) (data rest-result))
# :token (first tokens)
# :remaining (remaining rest-result)}
# :none {:status :group :type name
# :data first-result
# :token (first tokens)
# :remaining (remaining rest-result)}
# :err (update rest-result :trace |(array/push % name))))
# :quiet
# (let [rest-result (apply-parser rest-parser (remaining first-result))]
# {:status :quiet
# :type name
# :data []
# :token (first tokens)
# :remaining (remaining rest-result)})
# (:err :none) first-result)))}))
(defn maybe/2 [name parser])
(defn maybe/1 [parser] (maybe/2 (pname parser) parser))
(defn maybe [& args]
(def arity (length args))
(if (= 1 arity) (maybe/1 ;args) (maybe/2 ;args)))
# (defn maybe
# ([parser] (maybe (pname parser) parser))
# ([name parser]
# {:name (kw+str name "-maybe")
# :rule (fn maybe-fn [tokens]
# (let [result (apply-parser parser tokens)]
# (if (pass? result)
# result
# {:status :group :type name :data [] :token (first tokens) :remaining tokens}
# )))}))
(defn flat/2 [name parser])
(defn flat/1 [parser] (flat/2 (pname parser) parser))
(defn flat [& args]
(def arity (length args))
(if (= 1 arity) (flat/1 ;args) (flat/2 ;args)))
# (defn flat
# ([parser] (flat (pname parser) parser))
# ([name parser]
# {:name (kw+str name "-flat")
# :rule (fn flat-fn [tokens]
# (let [result (apply-parser parser tokens)]
# (if (pass? result) (first (get result :data)) result)))}))
(defn group/2 [name parser])
(defn group/1 [])
(defn group (defn group
([parser] (group (pname parser) parser)) ([parser] (group (pname parser) parser))