diff --git a/janet/parser.janet b/janet/parser.janet new file mode 100644 index 0000000..d631836 --- /dev/null +++ b/janet/parser.janet @@ -0,0 +1,323 @@ +(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)))) diff --git a/src/ludus/scanner.janet b/janet/scanner.janet similarity index 100% rename from src/ludus/scanner.janet rename to janet/scanner.janet diff --git a/src/ludus/grammar.janet b/src/ludus/grammar.janet new file mode 100644 index 0000000..334c491 --- /dev/null +++ b/src/ludus/grammar.janet @@ -0,0 +1,273 @@ +(ns ludus.grammar + (:require + #?( + :clj [ludus.parser :refer :all] + :cljs [ludus.parser + :refer [choice quiet one+ zero+ group order-0 order-1 flat maybe weak-order] + :refer-macros [defp] + ] + ) + [ludus.scanner :as s] + )) + +(declare expression pattern binding-expr non-binding simple) + +(defp separator choice [:comma :newline :break]) + +(defp separators quiet one+ separator) + +(defp terminator choice [:newline :semicolon :break]) + +(defp terminators quiet one+ terminator) + +(defp nls? quiet zero+ :newline) + +(defp splat group order-1 [(quiet :splat) :word]) + +(defp patt-splat-able flat choice [:word :ignored :placeholder]) + +(defp splattern group order-1 [(quiet :splat) (maybe patt-splat-able)]) + +(defp literal flat choice [:nil :true :false :number :string]) + +(defp tuple-pattern-term flat choice [pattern splattern]) + +(defp tuple-pattern-entry weak-order [tuple-pattern-term separators]) + +(defp tuple-pattern group order-1 [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ tuple-pattern-entry) + (quiet :rparen)]) + +(defp list-pattern group order-1 [(quiet :lbracket) + (quiet (zero+ separator)) + (zero+ tuple-pattern-entry) + (quiet :rbracket)]) + +(defp pair-pattern group weak-order [:keyword pattern]) + +(defp typed group weak-order [:word (quiet :as) :keyword]) + +(defp dict-pattern-term flat choice [pair-pattern typed :word splattern]) + +(defp dict-pattern-entry weak-order [dict-pattern-term separators]) + +(defp dict-pattern group order-1 [(quiet :startdict) + (quiet (zero+ separator)) + (zero+ dict-pattern-entry) + (quiet :rbrace) + ]) + +; (defp struct-pattern group order-1 [(quiet :startstruct) +; (quiet (zero+ separator)) +; (zero+ dict-pattern-entry) +; (quiet :rbrace) +; ]) + +(defp guard order-0 [(quiet :if) simple]) + +(defp pattern flat choice [literal + :ignored + :placeholder + typed + :word + :keyword + :else + tuple-pattern + dict-pattern + ;struct-pattern + list-pattern]) + +(defp match-clause group weak-order [pattern (maybe guard) (quiet :rarrow) expression]) + +(defp match-entry weak-order [match-clause terminators]) + +(defp match group order-1 [(quiet :match) simple nls? + (quiet :with) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ match-entry) + (quiet :rbrace) + ]) + +(defp when-lhs flat choice [simple :placeholder :else]) + +(defp when-clause group weak-order [when-lhs (quiet :rarrow) expression]) + +(defp when-entry weak-order [when-clause terminators]) + +(defp when-expr group order-1 [(quiet :when) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ when-entry) + (quiet :rbrace)]) + +(defp let-expr group order-1 [(quiet :let) + pattern + (quiet :equals) + nls? + non-binding]) + +(defp condition flat choice [simple let-expr]) + +(defp if-expr group order-1 [(quiet :if) + nls? + condition + nls? + (quiet :then) + expression + nls? + (quiet :else) + expression]) + +(defp tuple-entry weak-order [non-binding separators]) + +(defp tuple group order-1 [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ tuple-entry) + (quiet :rparen)]) + +(defp list-term flat choice [splat non-binding]) + +(defp list-entry order-1 [list-term separators]) + +(defp list-literal group order-1 [(quiet :lbracket) + (quiet (zero+ separator)) + (zero+ list-entry) + (quiet :rbracket)]) + +(defp set-literal group order-1 [(quiet :startset) + (quiet (zero+ separator)) + (zero+ list-entry) + (quiet :rbrace)]) + +(defp pair group order-0 [:keyword non-binding]) + +;; "struct-term" and "struct-entry" are necessary for nses +(defp struct-term flat choice [:word pair]) + +(defp struct-entry order-1 [struct-term separators]) + +; (defp struct-literal group order-1 [(quiet :startstruct) +; (quiet (zero+ separator)) +; (zero+ struct-entry) +; (quiet :rbrace)]) + +(defp dict-term flat choice [splat :word pair]) + +(defp dict-entry order-1 [dict-term separators]) + +(defp dict group order-1 [(quiet :startdict) + (quiet (zero+ separator)) + (zero+ dict-entry) + (quiet :rbrace)]) + +(defp arg-expr flat choice [:placeholder non-binding]) + +(defp arg-entry weak-order [arg-expr separators]) + +(defp args group order-1 [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ arg-entry) + (quiet :rparen)]) + +(defp recur-call group order-1 [(quiet :recur) tuple]) + +(defp synth-root flat choice [:keyword :word]) + +(defp synth-term flat choice [args :keyword]) + +(defp synthetic group order-1 [synth-root (zero+ synth-term)]) + +(defp fn-clause group order-1 [tuple-pattern (maybe guard) (quiet :rarrow) expression]) + +(defp fn-entry order-1 [fn-clause terminators]) + +(defp fn-compound group order-1 [(quiet :lbrace) + nls? + (maybe :string) + (quiet (zero+ terminator)) + (one+ fn-entry) + (quiet :rbrace) + ]) + +(defp clauses flat choice [fn-clause fn-compound]) + +(defp fn-named group order-1 [(quiet :fn) :word clauses]) + +(defp lambda group order-1 [(quiet :fn) fn-clause]) + +(defp block-line weak-order [expression terminators]) + +(defp block group order-1 [(quiet :lbrace) + (quiet (zero+ terminator)) + (one+ block-line) + (quiet :rbrace)]) + +(defp pipeline quiet order-0 [nls? :pipeline]) + +(defp do-entry order-1 [pipeline expression]) + +(defp do-expr group order-1 [(quiet :do) + expression + (one+ do-entry) + ]) + +(defp ref-expr group order-1 [(quiet :ref) :word (quiet :equals) expression]) + +; (defp spawn group order-1 [(quiet :spawn) expression]) + +; (defp receive group order-1 [(quiet :receive) (quiet :lbrace) +; (quiet (zero+ terminator)) +; (one+ match-entry) +; (quiet :rbrace) +; ]) + +(defp compound-loop group order-0 [(quiet :lbrace) + (quiet (zero+ terminator)) + (one+ fn-entry) + (quiet :rbrace)]) + +(defp loop-expr group order-1 [(quiet :loop) tuple (quiet :with) + (flat (choice :loop-body [fn-clause compound-loop]))]) + +(defp repeat-expr group order-1 [(quiet :repeat) (choice :times [:word :number]) non-binding]) + +(defp collection flat choice [;struct-literal + dict list-literal set-literal tuple]) + +(defp panic group order-1 [(quiet :panic) expression]) + +(defp simple flat choice [literal collection synthetic recur-call lambda panic]) + +(defp compound flat choice [match loop-expr if-expr when-expr do-expr block repeat-expr]) + +(defp binding-expr flat choice [fn-named let-expr ref-expr]) + +(defp non-binding flat choice [simple compound]) + +(defp expression flat choice [binding-expr non-binding]) + +(defp test-expr group order-1 [(quiet :test) :string non-binding]) + +(defp import-expr group order-1 [(quiet :import) :string (quiet :as) :word]) + +(defp ns-expr group order-1 [(quiet :ns) + :word + (quiet :lbrace) + (quiet (zero+ separator)) + (zero+ struct-entry) + (quiet :rbrace)]) + +(defp use-expr group order-1 [(quiet :use) :word]) + +(defp toplevel flat choice [import-expr + ns-expr + expression + test-expr + use-expr]) + +(defp script-line weak-order [toplevel terminators]) + +(defp script order-0 [nls? + (one+ script-line) + (quiet :eof)]) +