324 lines
12 KiB
Plaintext
324 lines
12 KiB
Plaintext
(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]
|
|
(defn recur [ps]
|
|
(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))))
|
|
|
|
(recur parsers))})
|
|
|
|
(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)))})
|
|
|
|
#### Start here
|
|
(defn weak-order [name parsers]
|
|
{:name name
|
|
:rule (fn order-fn [tokens]
|
|
(let [origin (first tokens)]
|
|
(loop [ps parsers
|
|
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)
|
|
(assoc result :status :quiet)
|
|
result)))})
|
|
|
|
(defn zero+
|
|
([parser] (zero+ (pname parser) parser))
|
|
([name parser]
|
|
{:name (kw+str name "-zero+")
|
|
:rule (fn zero+fn [tokens]
|
|
(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+
|
|
([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
|
|
([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
|
|
([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
|
|
([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))
|
|
(assoc result :status :ok)
|
|
result)))}))
|
|
|
|
(defn err-msg [{token :token trace :trace}]
|
|
(println "Unexpected token " (get token :type) " on line " (get token :line))
|
|
(println "Expected token " (first trace)))
|
|
|
|
(defmacro defp [name & items]
|
|
(let [arg (last items)
|
|
fns (into [] (butlast items))]
|
|
`(defn ~name [] ((apply comp ~fns) (keyword '~name) ~arg))))
|