From c6eeed4f4c7a27f52e65d8883c34718b6353f41d Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Fri, 26 May 2023 15:07:41 -0400 Subject: [PATCH] Use defp macros for parsers; update grammar using defp; update interpreter with new node names --- TODO.xit | 10 + src/ludus/grammar.clj | 465 +++++++++++++++++++------------------- src/ludus/interpreter.clj | 45 ++-- src/ludus/parser_new.clj | 24 ++ 4 files changed, 296 insertions(+), 248 deletions(-) diff --git a/TODO.xit b/TODO.xit index 85b82bc..57decd2 100644 --- a/TODO.xit +++ b/TODO.xit @@ -2,3 +2,13 @@ [ ] Write send function [ ] ---- Investigate weird timing issue in current send implementation [ ] Investigate with-bindings and virtual threads + +[ ] Fix recursive definition problems in grammar.clj + +[ ] Wire up new interpreter to repl, script situation + +[ ] Write compiler + +[ ] Merge new interpreter + +[ ] Get drawing working? diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 09ff1db..26575c4 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -4,295 +4,306 @@ (declare expression pattern) -(def separator (choice :separator [:comma :newline :break])) +;(def separator (choice :separator [:comma :newline :break])) +(defp separator [choice] [:comma :newline :break]) -(def separators (quiet (one+ separator))) +;(def separators (quiet (one+ separator))) +(defp separators quiet one+ separator) -(def terminator (choice :terminator [:newline :semicolon :break])) +;(def terminator (choice :terminator [:newline :semicolon :break])) +(defp terminator choice [:newline :semicolon :break]) -(def terminators (quiet (one+ terminator))) +;(def terminators (quiet (one+ terminator))) +(defp terminators quiet one+ terminator) -(def nls? (quiet (zero+ :nls :newline))) +;(def nls? (quiet (zero+ :nls :newline))) +(defp nls? quiet zero+ :newline) -(def splat (group (order-1 :splat [(quiet :splat) :word]))) +;(def splat (group (order-1 :splat [(quiet :splat) :word]))) +(defp splat group order-1 [(quiet :splat) :word]) -(def splattern (group (order-1 :splat [(quiet :splat) (flat (choice :splatted [:word :ignored :placeholder]))]))) +;(def splattern (group (order-1 :splat [(quiet :splat) (maybe (flat (choice :splatted [:word :ignored :placeholder])))]))) +(defp patt-splat-able quiet flat choice [:word :ignored :placeholder]) +(defp splattern group order-1 [(quiet :splat) (maybe patt-splat-able)]) -(def literal (flat (choice :literal [:nil :true :false :number :string]))) +;(def literal (flat (choice :literal [:nil :true :false :number :string]))) +(defp literal flat choice [:nil :true :false :number :string]) -(def tuple-pattern-term (flat (choice :tuple-pattern-term [pattern splattern]))) +;(def tuple-pattern-term (flat (choice :tuple-pattern-term [pattern splattern]))) +(defp tuple-pattern-term flat choice [pattern splattern]) -(def tuple-pattern-entry (weak-order :tuple-pattern-entry [tuple-pattern-term separators])) +;(def tuple-pattern-entry (weak-order :tuple-pattern-entry [tuple-pattern-term separators])) +(defp tuple-pattern-entry weak-order [tuple-pattern-term separators]) -(def tuple-pattern (group (order-1 :tuple-pattern - [(quiet :lparen) - (quiet (zero+ separator)) - (zero+ tuple-pattern-entry) - (quiet :rparen)]))) - -(def list-pattern (group (order-1 :list-pattern - [(quiet :lbracket) - (quiet (zero+ separator)) - (zero+ tuple-pattern-entry) - (quiet :rbracket)]))) - -(def pair-pattern (order-0 :pair-pattern [:keyword pattern])) - -(def dict-pattern-term (flat (choice :dict-pattern-term [pair-pattern :word splattern]))) - -(def dict-pattern-entry (weak-order :dict-pattern-entry [dict-pattern-term separators])) - -(def dict-pattern (group (order-1 :dict-pattern - [(quiet :startdict) - (quiet (zero+ separator)) - (zero+ dict-pattern-entry) - (quiet :rbrace) - ]))) - -(def struct-pattern (group (order-1 :struct-pattern - [(quiet :startstruct) - (quiet (zero+ separator)) - (zero+ dict-pattern-entry) - (quiet :rbrace) - ]))) - -(def constraint (order-0 :constraint [(quiet :when) expression])) - -(def typed (group (weak-order :typed [:word (quiet :as) :keyword]))) - -(def pattern (flat (choice :pattern [literal :ignored :placeholder typed :word :keyword tuple-pattern dict-pattern struct-pattern list-pattern]))) - -(def match-clause (group (weak-order :match-clause - [pattern (maybe constraint) (quiet :rarrow) expression]))) - -(def match-entry (weak-order :match-entry [match-clause terminators])) - -(def match (group (order-1 :match - [(quiet :match) expression nls? - (quiet :with) (quiet :lbrace) - (quiet (zero+ terminator)) - (one+ match-entry) - (quiet :rbrace) - ]))) - -(def iff (group (order-1 :if [(quiet :if) - nls? - expression - nls? - (quiet :then) - expression - nls? - (quiet :else) - expression]))) - -(def cond-lhs (flat (choice :cond-lhs [expression :placeholder :else]))) - -(def cond-clause (group (weak-order :cond-clause [cond-lhs (quiet :rarrow) expression]))) - -(def cond-entry (weak-order :cond-entry [cond-clause terminators])) - -(def condd (group (order-1 :cond [(quiet :cond) (quiet :lbrace) - (quiet (zero+ terminator)) - (one+ cond-entry) - (quiet :rbrace)]))) - -(def lett (group (order-1 :let [(quiet :let) - pattern - (quiet :equals) - nls? - expression]))) - -(def tuple-entry (weak-order :tuple-entry [expression separators])) - -(def tuple (group (order-1 :tuple [(quiet :lparen) +(defp tuple-pattern group order-1 [(quiet :lparen) (quiet (zero+ separator)) - (zero+ tuple-entry) - (quiet :rparen)]))) + (zero+ tuple-pattern-entry) + (quiet :rparen)]) -(def list-term (flat (choice :list-term [splat expression]))) +(defp list-pattern group order-1 [(quiet :lbracket) + (quiet (zero+ separator)) + (zero+ tuple-pattern-entry) + (quiet :rbracket)]) -(def list-entry (order-1 :list-entry [list-term separators])) +(defp pair-pattern order-0 [:keyword #'pattern]) -(def listt (group (order-1 :list - [(quiet :lbracket) - (quiet (zero+ separator)) - (zero+ list-entry) - (quiet :rbracket)]))) +(defp dict-pattern-term flat choice [pair-pattern :word splattern]) -(def sett (group (order-1 :set [ - (quiet :startset) - (quiet (zero+ separator)) - (zero+ list-entry) - (quiet :rbrace)]))) +(defp dict-pattern-entry weak-order [dict-pattern-term separators]) -(def pair (group (order-0 :pair [:keyword expression]))) +(defp dict-pattern group order-1 [(quiet :startdict) + (quiet (zero+ separator)) + (zero+ dict-pattern-entry) + (quiet :rbrace) + ]) -(def struct-term (flat (choice :struct-term [:word pair]))) +(defp struct-pattern group order-1 [(quiet :startstruct) + (quiet (zero+ separator)) + (zero+ dict-pattern-entry) + (quiet :rbrace) + ]) -(def struct-entry (order-1 :struct-entry [struct-term separators])) +(defp guard order-0 [(quiet :when) expression]) -(def structt (group (order-1 :struct - [(quiet :startstruct) - (quiet (zero+ separator)) - (zero+ struct-entry) - (quiet :rbrace)]))) +(defp typed group weak-order [:word (quiet :as) :keyword]) -(def dict-term (flat (choice :dict-term [splat :word pair]))) +(defp pattern flat choice [literal + :ignored + :placeholder + typed + :word + :keyword + tuple-pattern + dict-pattern + struct-pattern + list-pattern]) -(def dict-entry (order-1 :dict-entry [dict-term separators])) +(defp match-clause group weak-order :match-clause [pattern (maybe guard) (quiet :rarrow) expression]) -(def dict (group (order-1 :dict - [(quiet :startdict) - (quiet (zero+ separator)) - (zero+ dict-entry) - (quiet :rbrace)]))) +(defp match-entry weak-order [match-clause terminators]) -(def arg-expr (flat (choice :arg-expr [:placeholder expression]))) +(defp match group order-1 [(quiet :match) expression nls? + (quiet :with) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ match-entry) + (quiet :rbrace) + ]) -(def arg-entry (weak-order :arg-entry [arg-expr separators])) +(defp if-expr group order-1 [(quiet :if) + nls? + expression + nls? + (quiet :then) + expression + nls? + (quiet :else) + expression]) -(def args (group (order-1 :args - [(quiet :lparen) - (quiet (zero+ separator)) - (zero+ arg-entry) - (quiet :rparen)]))) +(defp cond-lhs flat choice [expression :placeholder :else]) -(def recurr (group (order-1 :recur [(quiet :recur) tuple]))) +(defp cond-clause group weak-order [cond-lhs (quiet :rarrow) expression]) -(def synth-root (flat (choice :synth-root [:keyword :word]))) +(defp cond-entry weak-order [cond-clause terminators]) -(def synth-term (flat (choice :synth-term [args :keyword]))) +(defp cond-expr group order-1 [(quiet :cond) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ cond-entry) + (quiet :rbrace)]) -(def synthetic (group (order-1 :synthetic [synth-root (zero+ synth-term)]))) +(defp let-expr group order-1 [(quiet :let) + pattern + (quiet :equals) + nls? + expression]) -(def fn-clause (group (order-1 :fn-clause [tuple-pattern (maybe constraint) (quiet :rarrow) expression]))) +(defp tuple-entry weak-order [expression separators]) + +(defp tuple group order-1 [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ tuple-entry) + (quiet :rparen)]) -(def fn-entry (order-1 :fn-entry [fn-clause terminators])) +(defp list-term flat choice [splat expression]) -(def compound (group (order-1 :compound [(quiet :lbrace) - nls? - (maybe :string) - (quiet (zero+ terminator)) - (one+ fn-entry) - (quiet :rbrace) - ]))) +(defp list-entry order-1 [list-term separators]) -(def clauses (flat (choice :clauses [fn-clause compound]))) +(defp list-literal group order-1 [(quiet :lbracket) + (quiet (zero+ separator)) + (zero+ list-entry) + (quiet :rbracket)]) -(def named (group (order-1 :named [:word clauses]))) +(defp set-literal group order-1 [(quiet :startset) + (quiet (zero+ separator)) + (zero+ list-entry) + (quiet :rbrace)]) -(def body (flat (choice :body [fn-clause named]))) +(defp pair group order-0 [:keyword expression]) -(def fnn (group (order-1 :fn [(quiet :fn) body]))) +(defp struct-term flat choice [:word pair]) -(def block-line (weak-order :block-line [expression terminators])) +(defp struct-entry order-1 [struct-term separators]) -(def block (group (order-1 :block [(quiet :lbrace) - (quiet (zero+ terminator)) - (one+ block-line) - (quiet :rbrace)]))) +(defp struct-literal group order-1 [(quiet :startstruct) + (quiet (zero+ separator)) + (zero+ struct-entry) + (quiet :rbrace)]) -(def pipeline (quiet (order-0 :pipeline [nls? :pipeline]))) +(defp dict-term flat choice [splat :word pair]) -(def do-entry (order-1 :do-entry [pipeline expression])) +(defp dict-entry order-1 [dict-term separators]) -(def doo (group (order-1 :do [(quiet :do) - expression - (one+ do-entry) - ]))) +(defp dict group order-1 [(quiet :startdict) + (quiet (zero+ separator)) + (zero+ dict-entry) + (quiet :rbrace)]) -(def reff (group (order-1 :ref [(quiet :ref) :word (quiet :equals) expression]))) +(defp arg-expr flat choice [:placeholder expression]) -(def spawn (group (order-1 :spawn [(quiet :spawn) expression]))) +(defp arg-entry weak-order [arg-expr separators]) -(def receive (group (order-1 :receive - [(quiet :receive) (quiet :lbrace) - (quiet (zero+ terminator)) - (one+ match-entry) - (quiet :rbrace) - ]))) +(defp args group order-1 [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ arg-entry) + (quiet :rparen)]) -(def compound-loop (group (order-0 :compound-loop - [(quiet :lbrace) - (quiet (zero+ terminator)) - (one+ fn-entry) - (quiet :rbrace)]))) +(defp recur-call group order-1 [(quiet :recur) tuple]) -(def loopp (group (order-1 :loop - [(quiet :loop) tuple (quiet :with) - (flat (choice :loop-body [fn-clause compound-loop]))]))) +(defp synth-root flat choice [:keyword :word]) -(def expression (flat (choice :expression [fnn - match - loopp - lett - iff - condd - spawn - receive - synthetic - recurr - block - doo - reff - structt - dict - listt - sett - tuple - literal]))) +(defp synth-term flat choice [args :keyword]) -(def testt (group (order-1 :test [(quiet :test) :string expression]))) +(defp synthetic group order-1 [synth-root (zero+ synth-term)]) -(def importt (group (order-1 :import [(quiet :import) :string (quiet :as) :word]))) +(defp fn-clause group order-1 [tuple-pattern (maybe constraint) (quiet :rarrow) expression]) -(def nss (group (order-1 :ns [(quiet :ns) - :word - (quiet :lbrace) - (quiet (zero+ separator)) - (zero+ struct-entry) - (quiet :rbrace)]))) +(defp fn-entry order-1 [fn-clause terminators]) -(def toplevel (flat (choice :toplevel [importt nss expression testt]))) +(defp compound group order-1 [(quiet :lbrace) + nls? + (maybe :string) + (quiet (zero+ terminator)) + (one+ fn-entry) + (quiet :rbrace) + ]) -(def script-line (weak-order :script-line [toplevel terminators])) +(defp clauses flat choice [fn-clause compound]) -(def script (order-0 :script [nls? - (one+ script-line) - (quiet :eof)])) +(defp named group order-1 [:word clauses]) + +(defp body flat choice [fn-clause named]) + +(defp fn-expr group order-1 [(quiet :fn) body]) + +(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 expression flat choice [fn-expr + match + loop-expr + let-expr + if-expr + cond-expr + spawn + receive + synthetic + recur-call + block + do-expr + ref-expr + struct-literal + dict + list-literal + set-literal + tuple + literal]) + +(defp test-expr group order-1 [(quiet :test) :string expression]) + +(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 toplevel flat choice [import-expr + ns-expr + expression + test-expr]) + +(defp script-line weak-order [toplevel terminators]) + +(defp script order-0 [nls? + (one+ script-line) + (quiet :eof)]) ;;; REPL -;; TODO: fix this recursive def bullshit problem +(def source + "2" + ) -(comment (def source - "if 1 then 2 else 3" - ) +(def rule (literal)) - (def result (apply-parser script source)) +(def tokens (-> source scan/scan :tokens)) + +(def result (apply-parser literal tokens)) - (defn report [node] - (when (fail? node) (err-msg node)) - node) +(defn report [node] + (when (fail? node) (err-msg node)) + node) - (defn clean [node] - (if (map? node) - (-> node - (report) - (dissoc - ;:status - :remaining - :token) - (update :data #(into [] (map clean) %))) - node)) +(defn clean [node] + (if (map? node) + (-> node + (report) + (dissoc + ;:status + :remaining + :token) + (update :data #(into [] (map clean) %))) + node)) - (defn tap [x] (println "\n\n\n\n******NEW RUN\n\n:::=> " x "\n\n") x) +(defn tap [x] (println "\n\n\n\n******NEW RUN\n\n:::=> " x "\n\n") x) - (def my-data (-> result - clean - tap - )) +(def my-data (-> result + clean + tap + )) - (println my-data)) \ No newline at end of file +(println my-data) \ No newline at end of file diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index e13e1f7..fe8f254 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -87,6 +87,7 @@ (recur (dec i))) {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))})))))))) +;; TODO: update this to use new AST representation (defn- match-list [pattern value ctx-vol] (cond (not (vector? value)) {:success false :reason "Could not match non-list value to list"} @@ -112,6 +113,7 @@ (recur (dec i))) {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))}))))))) +;; TODO: update this to match new AST representation (defn- match-dict [pattern value ctx-vol] (cond (not (map? value)) @@ -139,6 +141,7 @@ {:success false :reason (str "Could not match " pattern " with " value " at key " kw " because there is no value at " kw)}))))))) +;; TODO: update this to use new AST representation (defn- match-struct [pattern value ctx-vol] (cond (not (map? value)) @@ -242,7 +245,7 @@ if-expr (first data) then-expr (second data) else-expr (nth data 2)] - (if (= (:type if-expr) :let) + (if (= (:type if-expr) :let-expr) (interpret-if-let ast ctx) (if (interpret-ast if-expr ctx) (interpret-ast then-expr ctx) @@ -563,9 +566,6 @@ (recur (:args output)) output))))) -(defn- panic [ast ctx] - (throw (ex-info (show/show (interpret-ast (:expr ast) ctx)) {:ast ast}))) - (defn- list-term [ctx] (fn [list member] (if (= (:type member) :splat) @@ -656,6 +656,7 @@ (vswap! ctx update-ctx {name ns}) ns)))) +;; TODO: update this to use new AST representation (defn- interpret-receive [ast ctx] (let [process-atom (get @process/processes self) inbox (promise) @@ -684,6 +685,7 @@ (recur (first clauses) (rest clauses)))) (throw (ex-info "Match Error: No match found" {:ast ast}))))))) +;; TODO: update send to be a function (here or in prelude) (defn- interpret-send [ast ctx] (let [msg (interpret-ast (:msg ast) ctx) pid (interpret-ast (:pid ast) ctx) @@ -715,8 +717,6 @@ (defn- interpret-literal [ast] (-> ast :data first)) -(interpret-literal {:data [false]}) - (defn interpret-ast [ast ctx] (println "interpreting ast type" (:type ast)) ;(println "AST: " ast) @@ -724,9 +724,9 @@ (:nil :true :false :number :string :keyword) (interpret-literal ast) - :let (interpret-let ast ctx) + :let-expr (interpret-let ast ctx) - :if (interpret-if ast ctx) + :if-expr (interpret-if ast ctx) :word (resolve-word ast ctx) @@ -734,28 +734,28 @@ :match (interpret-match ast ctx) - :cond (interpret-cond ast ctx) + :cond-expr (interpret-cond ast ctx) - :fn (interpret-fn ast ctx) + :fn-expr (interpret-fn ast ctx) - :do (interpret-do ast ctx) + :do-expr (interpret-do ast ctx) :placeholder ::data/placeholder - :ns (interpret-ns ast ctx) + :ns-expr (interpret-ns ast ctx) - :import (interpret-import ast ctx) + :import-expr (interpret-import ast ctx) - :ref (interpret-ref ast ctx) + :ref-expr (interpret-ref ast ctx) - ::ast/spawn (interpret-spawn ast ctx) + ; ::ast/spawn (interpret-spawn ast ctx) - ::ast/receive (interpret-receive ast ctx) + ; ::ast/receive (interpret-receive ast ctx) - :recur + :recur-call {::data/recur true :args (interpret-ast (-> ast :data first) ctx)} - :loop (interpret-loop ast ctx) + :loop-expr (interpret-loop ast ctx) :block (let [exprs (:data ast) @@ -779,17 +779,18 @@ (let [members (:data ast)] (into [::data/tuple] (map #(interpret-ast % ctx)) members)) - :list (interpret-list ast ctx) + :list-literal (interpret-list ast ctx) - :set (interpret-set ast ctx) + :set-literal (interpret-set ast ctx) :dict (interpret-dict ast ctx) - :struct + :struct-literal (let [members (:members ast)] (interpret-struct ast ctx)) (throw (ex-info "Unknown AST node type" {:ast ast})))) +;; TODO: update this to use new parser pipeline & new AST representation (defn interpret-file [parsed file] (try (let [base-ctx (volatile! (merge {:file file} prelude/prelude process/process))] @@ -800,6 +801,7 @@ (println (ex-message e)) (System/exit 67)))) +;; TODO: update this to use new parser pipeline & new AST representation (defn interpret [parsed file] (try (let [base-ctx (volatile! (merge {:file file} prelude/prelude process/process)) @@ -833,6 +835,7 @@ (println (ex-message e)) (pp/pprint (ex-data e))))) +;; TODO: update this to use new parser pipeline & new AST representation (defn interpret-repl ([parsed ctx] (let [orig-ctx @ctx diff --git a/src/ludus/parser_new.clj b/src/ludus/parser_new.clj index c858d09..62eb781 100644 --- a/src/ludus/parser_new.clj +++ b/src/ludus/parser_new.clj @@ -47,6 +47,7 @@ (let [result (cond (keyword? parser) (apply-kw-parser parser tokens) (:rule parser) (apply-fn-parser parser tokens) + (fn? parser) (apply-fn-parser (parser) tokens) :else (throw (Exception. "`apply-parser` requires a parser")))] ;(println "Parser result " (? (:name parser) parser) (:status result)) result @@ -308,3 +309,26 @@ (defn err-msg [{token :token trace :trace}] (println "Unexpected token " (:type token) " on line " (:line token)) (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)))) + +(macroexpand '(defp foo group choice [:one :two])) + +(comment (defp foo quiet choice [:one :two]) + + (def group-choice (apply comp '(group choice))) + + (group-choice :thing [:a :b]) + + ((apply comp [group choice]) :foo [:one :two]) + + (fn? foo) + + foo + + (keyword 'foo) + + (foo))