From 4fd593752b398b596ae50e0c2524dfd8267daba7 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sat, 20 May 2023 14:18:30 -0400 Subject: [PATCH] Finally get it right? --- src/ludus/grammar.clj | 24 +++++++-------- src/ludus/parser_new.clj | 63 +++++++++++++++++++++++++++++++++------- 2 files changed, 63 insertions(+), 24 deletions(-) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 3dfc9cc..2a10612 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -22,7 +22,7 @@ (def tuple-pattern-term (flat (choice :tuple-pattern-term [pattern splattern]))) -(def tuple-pattern-entry (order-1 :tuple-pattern-entry [tuple-pattern-term (quiet (one+ separator))])) +(def tuple-pattern-entry (weak-order :tuple-pattern-entry [tuple-pattern-term separators])) (def tuple-pattern (group (order-1 :tuple-pattern [(quiet :lparen) @@ -40,7 +40,7 @@ (def dict-pattern-term (flat (choice :dict-pattern-term [pair-pattern :word splattern]))) -(def dict-pattern-entry (order-1 :dict-pattern-entry [dict-pattern-term (quiet (one+ separator))])) +(def dict-pattern-entry (weak-order :dict-pattern-entry [dict-pattern-term separators])) (def dict-pattern (group (order-1 :dict-pattern [(quiet :startdict) @@ -63,7 +63,7 @@ (def match-clause (group (order-0 :match-clause [pattern (maybe constraint) (quiet :rarrow) expression]))) -(def match-entry (order-0 :match-entry [match-clause (quiet (one+ terminator))])) +(def match-entry (weak-order :match-entry [match-clause terminators])) (def match (group (order-1 :match [(quiet :match) expression nls? @@ -87,7 +87,7 @@ (def cond-clause (group (order-0 :cond-clause [cond-lhs (quiet :rarrow) expression]))) -(def cond-entry (order-0 :cond-entry [cond-clause (quiet (one+ terminator))])) +(def cond-entry (weak-order :cond-entry [cond-clause terminators])) (def condd (order-1 :cond [(quiet :cond) (quiet :lbrace) (quiet (zero+ terminator)) @@ -100,7 +100,7 @@ nls? expression]))) -(def tuple-entry (order-1 :tuple-entry [expression separators])) +(def tuple-entry (weak-order :tuple-entry [expression separators])) (def tuple (group (order-1 :tuple [(quiet :lparen) (quiet (zero+ separator)) @@ -181,7 +181,7 @@ (def fnn (group (order-1 :fn [(quiet :fn) body]))) -(def block-line (order-1 :block-line [expression terminators])) +(def block-line (weak-order :block-line [expression terminators])) (def block (group (order-1 :block [(quiet :lbrace) (quiet (zero+ terminator)) @@ -251,7 +251,7 @@ (def toplevel (flat (choice :toplevel [importt nss expression testt]))) -(def script-line (order-0 :script-line [toplevel terminators])) +(def script-line (weak-order :script-line [toplevel terminators])) (def script (order-0 :script [nls? (one+ script-line) @@ -260,20 +260,18 @@ ;;;;;;;;;;;;;;;; REPL CRUFT -;;TODO: improve current bug reporting in the parser -;; --e.g., give functions better names in the stack trace -;; --I think this might require a macro (::facepalm::) ;;TODO: fix forward declaration errors -;;TODO: in, e.g., script-line (repeated, separated entities -- zero/one+->order), order-0 gives an error before a closing token (in this case, :eof), because it's not a line; but using order-1 parses correctly but swallows orders further down. I need to revisit how no match vs. errors pass through the system, esp. the combination of repeats and orders (def eg (:tokens (scan/scan - "{1; 2; 3; (1, _)}" + " + test \"foo\" bar + " ))) -(def result (apply-parser block eg)) +(def result (apply-parser script eg)) (defn report [node] diff --git a/src/ludus/parser_new.clj b/src/ludus/parser_new.clj index 71c9db8..c36aab6 100644 --- a/src/ludus/parser_new.clj +++ b/src/ludus/parser_new.clj @@ -70,19 +70,15 @@ {:status :none :token (first tokens) :trace [name] :remaining rem-ts} :else (recur rem-ps)))))}) -;; TODO - figure out a scheme for zero and one lookahead -;; Lookahead isn't even the right term here + (defn order-1 [name parsers] {:name name :rule (fn order-fn [tokens] (let [origin (first tokens) first-result (apply-parser (first parsers) tokens)] (case (:status first-result) - (:err :none) - {:status :none - :token (first tokens) - :trace [name] - :remaining tokens} + (:err :none) + (update (assoc first-result :trace #(conj % name)) :status :none) (:ok :quiet :group) (loop [ps (rest parsers) @@ -122,6 +118,7 @@ (vec (concat results (:data result))) res-rem) :quiet (recur (rest ps) results res-rem) + (:err :none) (assoc (update result :trace #(conj % name)) :status :err))))))))}) @@ -165,9 +162,55 @@ (vec (concat results (:data result))) res-rem) :quiet (recur (rest ps) results res-rem) - (:err :none) + + (:err :none) (assoc (update result :trace #(conj % name)) :status :err)))))))}) +(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 (:status result) + :ok {:status :group + :type name + :data (conj 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 (vec (concat results (:data result))) + :token origin + :remaining res-rem} + + (:err :none) + (update result :trace #(conj % name))) + + ;; Still parsers left in the vector: recur + (case (:status result) + :ok (recur (rest ps) (conj results result) res-rem) + :group (recur (rest ps) + (vec (concat results (:data result))) + res-rem) + :quiet (recur (rest ps) results res-rem) + + (:err :none) + (update result :trace #(conj % name))))))))}) + + (defn quiet [parser] {:name (kw+str (? (:name parser) parser) "-quiet") :rule (fn quiet-fn [tokens] @@ -219,9 +262,7 @@ :token (first tokens) :remaining (remaining rest-result)} - :err (update rest-result :trace #(conj % name))) - - ) + :err (update rest-result :trace #(conj % name)))) :quiet (let [rest-result (apply-parser rest-parser (remaining first-result))]