ludus/janet/parser.janet
2024-03-25 16:04:54 -04:00

409 lines
15 KiB
Plaintext

### in repl, make sure to (os/cd) into the janet dir
# (os/cd "janet")
(import ./clj-loop :prefix "")
(defn ? [val default] (if (nil? val) default val))
(defn ok? [{:status status}]
(= status :ok))
(def failing {:err true :none true})
(def passing {:ok true :group true :quiet true})
(defn pass? [{:status status}] (get passing status))
(defn fail? [{:status status}] (get failing status))
(defn data [{:data d}] d)
(defn remaining [{:remaining r}] r)
(defn pname [parser] (? (get parser :name) parser))
(defn kw+str [kw mystr] (keyword (string kw) mystr))
(defn value [token]
(if (= :none (get token :literal)) (get token :lexeme) (get token :literal)))
(defn rest [seq]
(let [len (length seq)]
(cond
(empty? seq) []
(tuple? seq) (tuple/slice 1 len)
(array? seq) (array/slice 1 len))))
(defn some? [val] (not (nil? val)))
(defn apply-kw-parser [kw tokens]
(let [token (first tokens)]
#(if (= kw (get token :type)) (println "Matched " kw))
(if (= kw (get token :type))
@{:status :ok
:type kw
:data (if (some? (value token)) @[(value token)] @[])
:token token
:remaining (rest tokens)}
@{:status :none :token token :trace [kw] :remaining (rest tokens)})))
(defn apply-fn-parser [parser tokens]
(let [rule (get parser :rule) name (get parser :name) result (rule tokens)]
#(if (pass? result) (println "Matched " (get parser :name)))
result))
(defn apply-parser [parser tokens]
#(println "Applying parser " (? (get parser :name) parser))
(let [result (cond
(keyword? parser) (apply-kw-parser parser tokens)
(get parser :rule) (apply-fn-parser parser tokens)
(function? parser) (apply-fn-parser (parser) tokens)
:else (error "`apply-parser` requires a parser"))]
#(println "Parser result " (? (get parser :name) parser) (get result :status))
result
))
(defn choice [name parsers]
{:name name
:rule (fn choice-fn [tokens]
(clj-loop [ps parsers]
(let [result (apply-parser (first ps) tokens)
rem-ts (remaining result)
rem-ps (rest ps)]
(cond
(pass? result)
{:status :ok :type name :data [result] :token (first tokens) :remaining rem-ts}
(= :err (get result :status))
(update result :trace |(array/push $ name))
(empty? rem-ps)
{:status :none :token (first tokens) :trace [name] :remaining rem-ts}
:else (recur rem-ps)))))})
(defn order-1 [name parsers]
{:name name
:rule (fn order-fn [tokens]
(let [origin (first tokens)
first-result (apply-parser (first parsers) tokens)]
(case (get first-result :status)
(:err :none)
(put (update first-result :trace |(array/push $ name)) :status :none)
(:ok :quiet :group)
(do (defn recur [ps results ts]
(let [result (apply-parser (first ps) ts)
res-rem (remaining result)]
(if (empty? (rest ps))
(case (get result :status)
:ok @{:status :group
:type name
:data (array/push results result)
:token origin
:remaining res-rem}
:quiet @{:status :group
:type name
:data results
:token origin
:remaining res-rem}
:group @{:status :group
:type name
:data (array/concat results (get result :data))
:token origin
:remaining res-rem}
(:err :none)
(put (update result :trace |(array/push $ name)) :status :err))
(case (get result :status)
:ok (recur (rest ps) (array/push results result) res-rem)
:group (recur (rest ps)
(array/concat results (get result :data))
res-rem)
:quiet (recur (rest ps) results res-rem)
(:err :none)
(put (update result :trace |(array/push $ name)) :status :err)))))
(recur
(get first-result :status)
(case (get first-result :status) :ok [first-result] :quiet [] :group (get first-result :data))
(remaining first-result))))))})
(defn order-0 [name parsers]
{:name name
:rule (fn order-fn [tokens]
(let [origin (first tokens)]
(defn recur [ps results ts]
(let [result (apply-parser (first ps) ts)
res-rem (remaining result)]
(if (empty? (rest ps))
## Nothing more: return
(case (get result :status)
:ok @{:status :group
:type name
:data (array/push results result)
:token origin
:remaining res-rem}
:quiet @{:status :group
:type name
:data results
:token origin
:remaining res-rem}
:group @{:status :group
:type name
:data (array/concat results (get result :data))
:token origin
:remaining res-rem}
(:err :none)
(put (update result :trace |(array/push $ name)) :status :err))
## Still parsers left in the vector: recur
(case (get result :status)
:ok (recur (rest ps) (array/push results result) res-rem)
:group (recur (rest ps)
(array/concat results (get result :data))
res-rem)
:quiet (recur (rest ps) results res-rem)
(:err :none)
(put (update result :trace |(array/push $ name)) :status :err)
(error (string "Got bad result: " (get result :status)))))))
(recur parsers [] tokens)))})
(defn weak-order [name parsers]
{:name name
:rule (fn order-fn [tokens]
(let [origin (first tokens)]
(clj-loop [ps parsers # now we can use my handy macro
results []
ts tokens]
(let [result (apply-parser (first ps) ts)
res-rem (remaining result)]
(if (empty? (rest ps))
## Nothing more: return
(case (get result :status)
:ok @{:status :group
:type name
:data (array/push results result)
:token origin
:remaining res-rem}
:quiet @{:status :group
:type name
:data results
:token origin
:remaining res-rem}
:group @{:status :group
:type name
:data (array/concat results (get result :data))
:token origin
:remaining res-rem}
(:err :none)
(update result :trace |(array/push $ name)))
## Still parsers left in the vector: recur
(case (get result :status)
:ok (recur (rest ps) (array/push results result) res-rem)
:group (recur (rest ps)
(array/concat results (get result :data))
res-rem)
:quiet (recur (rest ps) results res-rem)
(:err :none)
(update result :trace |(array/push $ name))))))))})
(defn quiet [parser]
{:name (kw+str (? (get parser :name) parser) "-quiet")
:rule (fn quiet-fn [tokens]
(let [result (apply-parser parser tokens)]
(if (pass? result)
(put result :status :quiet)
result)))})
(defn zero+/2 [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 zero+/1 [parser] (zero+/2 (pname parser) 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+")
: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 one+/1 [parser] (one+/2 (pname parser) parser))
(defn one+ [& args]
(def arity (length args))
(if (= 1 arity) (one+/1 ;args) (one+/2 ;args)))
# (defn one+
# ([parser] (one+ (pname parser) parser))
# ([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
([parser] (group (pname parser) parser))
([name parser]
{:name (kw+str name "-group")
:rule (fn group-fn [tokens]
(let [result (apply-parser parser tokens)]
(if (= :group (get result :status))
(put result :status :ok)
result)))}))
(defn err-msg [{:token token :trace trace}]
(print "Unexpected token " (get token :type) " on line " (get token :line))
(print "Expected token " (first trace)))
(defn butlast [xs] (if (empty? xs) [] (slice xs 0 -2)))
(defmacro defp [name & items]
(let [arg (last items)
fns (butlast items)]
~(defn ,name [] ((apply comp ,fns) (keyword ',name) ,arg))))