409 lines
15 KiB
Plaintext
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))))
|