From 4936daa8dccfe906480b6750f3a554ab9e4adb35 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Tue, 2 May 2023 19:02:28 -0400 Subject: [PATCH 01/43] dequalify token keywords --- src/ludus/scanner.clj | 160 +++++++++++++++++++++--------------------- 1 file changed, 80 insertions(+), 80 deletions(-) diff --git a/src/ludus/scanner.clj b/src/ludus/scanner.clj index 7884bf7..99d7967 100644 --- a/src/ludus/scanner.clj +++ b/src/ludus/scanner.clj @@ -7,66 +7,66 @@ (def reserved-words "List of Ludus reserved words." ;; see ludus-spec repo for more info - {"as" ::token/as ;; impl for `import`; not yet for patterns - "cond" ::token/cond ;; impl - "do" ::token/do ;; impl - "else" ::token/else ;; impl - "false" ::token/false ;; impl - "fn" ::token/fn ;; impl - "if" ::token/if ;; impl - "import" ::token/import ;; impl - "let" ::token/let ;; impl - "loop" ::token/loop ;; impl - "match" ::token/match ;; impl - "nil" ::token/nil ;; impl - "ns" ::token/ns ;; impl - ;; "panic!" ::token/panic ;; impl (should be a function) - "recur" ::token/recur ;; impl - "ref" ::token/ref ;; impl - "then" ::token/then ;; impl - "true" ::token/true ;; impl - "with" ::token/with ;; impl + {"as" :as ;; impl for `import`; not yet for patterns + "cond" :cond ;; impl + "do" :do ;; impl + "else" :else ;; impl + "false" :false ;; impl + "fn" :fn ;; impl + "if" :if ;; impl + "import" :import ;; impl + "let" :let ;; impl + "loop" :loop ;; impl + "match" :match ;; impl + "nil" :nil ;; impl + "ns" :ns ;; impl + ;; "panic!" :panic ;; impl (should be a function) + "recur" :recur ;; impl + "ref" :ref ;; impl + "then" :then ;; impl + "true" :true ;; impl + "with" :with ;; impl ;; actor model/concurrency - "receive" ::token/receive - ;;"self" ::token/self ;; maybe not necessary?: self() is a function - ;;"send" ::token/send ;; not necessary: send(pid, message) is a function - "spawn" ::token/spawn - ;;"to" ::token/to ;; not necessary if send is a function + "receive" :receive + ;;"self" :self ;; maybe not necessary?: self() is a function + ;;"send" :send ;; not necessary: send(pid, message) is a function + "spawn" :spawn + ;;"to" :to ;; not necessary if send is a function ;; type system - ;; "data" ::token/data ;; we are going to tear out datatypes for now: see if dynamism works for us + ;; "data" :data ;; we are going to tear out datatypes for now: see if dynamism works for us ;; others - "repeat" ::token/repeat ;; syntax sugar over "loop": still unclear what this syntax could be - "test" ::token/test - "when" ::token/when - ;; "module" ::token/module ;; not necessary if we don't have datatypes + "repeat" :repeat ;; syntax sugar over "loop": still unclear what this syntax could be + "test" :test + "when" :when + ;; "module" :module ;; not necessary if we don't have datatypes }) (defn- new-scanner "Creates a new scanner." [source] - {::source source - ::length (count source) - ::errors [] - ::start 0 - ::current 0 - ::line 1 - ::tokens []}) + {:source source + :length (count source) + :errors [] + :start 0 + :current 0 + :line 1 + :tokens []}) (defn- at-end? "Tests if a scanner is at end of input." [scanner] - (>= (::current scanner) (::length scanner))) + (>= (:current scanner) (:length scanner))) (defn- current-char "Gets the current character of the scanner." [scanner] - (nth (::source scanner) (::current scanner) nil)) + (nth (:source scanner) (:current scanner) nil)) (defn- advance "Advances the scanner by a single character." [scanner] - (update scanner ::current inc)) + (update scanner :current inc)) (defn- next-char "Gets the next character from the scanner." @@ -75,7 +75,7 @@ (defn- current-lexeme [scanner] - (subs (::source scanner) (::start scanner) (::current scanner))) + (subs (:source scanner) (:start scanner) (:current scanner))) (defn- char-in-range? [start end char] (and char @@ -120,28 +120,28 @@ ([scanner token-type] (add-token scanner token-type nil)) ([scanner token-type literal] - (update scanner ::tokens conj + (update scanner :tokens conj (token/token token-type (current-lexeme scanner) literal - (::line scanner) - (::start scanner))))) + (:line scanner) + (:start scanner))))) ;; TODO: errors should also be in the vector of tokens ;; The goal is to be able to be able to hand this to an LSP? ;; Do we need a different structure (defn- add-error [scanner msg] (let [token (token/token - ::token/error + :error (current-lexeme scanner) nil - (::line scanner) - (::start scanner)) + (:line scanner) + (:start scanner)) err-token (assoc token :message msg)] (-> scanner - (update ::errors conj err-token) - (update ::tokens conj err-token)))) + (update :errors conj err-token) + (update :tokens conj err-token)))) (defn- add-keyword [scanner] @@ -149,7 +149,7 @@ key ""] (let [char (current-char scanner)] (cond - (terminates? char) (add-token scanner ::token/keyword (keyword key)) + (terminates? char) (add-token scanner :keyword (keyword key)) (word-char? char) (recur (advance scanner) (str key char)) :else (add-error scanner (str "Unexpected " char "after keyword :" key)))))) @@ -166,7 +166,7 @@ (= curr \.) (if float? (add-error scanner (str "Unexpected second decimal point after " num ".")) (recur (advance scanner) (str num curr) true)) - (terminates? curr) (add-token scanner ::token/number (edn/read-string num)) + (terminates? curr) (add-token scanner :number (edn/read-string num)) (digit? curr) (recur (advance scanner) (str num curr) float?) :else (add-error scanner (str "Unexpected " curr " after number " num ".")))))) @@ -179,10 +179,10 @@ (let [char (current-char scanner)] (case char \newline (add-error scanner "Unterminated string.") - \" (add-token (advance scanner) ::token/string string) + \" (add-token (advance scanner) :string string) \\ (let [next (next-char scanner) scanner (if (= next \newline) - (update scanner ::line inc) + (update scanner :line inc) scanner)] (recur (advance (advance scanner)) (str string next))) (if (at-end? scanner) @@ -195,7 +195,7 @@ word (str char)] (let [curr (current-char scanner)] (cond - (terminates? curr) (add-token scanner (get reserved-words word ::token/word)) + (terminates? curr) (add-token scanner (get reserved-words word :word)) (word-char? curr) (recur (advance scanner) (str word curr)) :else (add-error scanner (str "Unexpected " curr " after word " word ".")))))) @@ -205,7 +205,7 @@ word (str char)] (let [curr (current-char scanner)] (cond - (terminates? curr) (add-token scanner ::token/datatype) + (terminates? curr) (add-token scanner :datatype) (word-char? curr) (recur (advance scanner) (str word curr)) :else (add-error scanner (str "Unexpected " curr " after datatype " word ".")))))) @@ -215,7 +215,7 @@ ignored "_"] (let [char (current-char scanner)] (cond - (terminates? char) (add-token scanner ::token/ignored) + (terminates? char) (add-token scanner :ignored) (word-char? char) (recur (advance scanner) (str ignored char)) :else (add-error scanner (str "Unexpected " char " after word " ignored ".")))))) @@ -224,7 +224,7 @@ comm (str char)] (let [char (current-char scanner)] (if (= \newline char) - (update scanner ::line inc) + (update scanner :line inc) (recur (advance scanner) (str comm char)))))) (defn- scan-token [scanner] @@ -233,36 +233,36 @@ next (current-char scanner)] (case char ;; one-character tokens - \( (add-token scanner ::token/lparen) - \) (add-token scanner ::token/rparen) - \{ (add-token scanner ::token/lbrace) - \} (add-token scanner ::token/rbrace) - \[ (add-token scanner ::token/lbracket) - \] (add-token scanner ::token/rbracket) - \; (add-token scanner ::token/semicolon) - \, (add-token scanner ::token/comma) - \newline (add-token (update scanner ::line inc) ::token/newline) - \\ (add-token scanner ::token/backslash) - \= (add-token scanner ::token/equals) - \> (add-token scanner ::token/pipeline) + \( (add-token scanner :lparen) + \) (add-token scanner :rparen) + \{ (add-token scanner :lbrace) + \} (add-token scanner :rbrace) + \[ (add-token scanner :lbracket) + \] (add-token scanner :rbracket) + \; (add-token scanner :semicolon) + \, (add-token scanner :comma) + \newline (add-token (update scanner :line inc) :newline) + \\ (add-token scanner :backslash) + \= (add-token scanner :equals) + \> (add-token scanner :pipeline) ;; two-character tokens ;; -> \- (cond - (= next \>) (add-token (advance scanner) ::token/rarrow) + (= next \>) (add-token (advance scanner) :rarrow) (digit? next) (add-number char scanner) :else (add-error scanner (str "Expected -> or negative number after `-`. Got `" char next "`"))) ;; at current we're not using this ;; <- ;;\< (if (= next \-) - ;; (add-token (advance scanner) ::token/larrow) + ;; (add-token (advance scanner) :larrow) ;; (add-error scanner (str "Expected <-. Got " char next))) ;; |> ;; Consider => , with =>> for bind ; \| (if (= next \>) - ; (add-token (advance scanner) ::token/pipeline) + ; (add-token (advance scanner) :pipeline) ; (add-error scanner (str "Expected |>. Got " char next))) ;; possible additional operator: bind/result @@ -272,23 +272,23 @@ ;; dict #{ \# (if (= next \{) - (add-token (advance scanner) ::token/startdict) + (add-token (advance scanner) :startdict) (add-error scanner (str "Expected beginning of dict: #{. Got " char next))) ;; set ${ \$ (if (= next \{) - (add-token (advance scanner) ::token/startset) + (add-token (advance scanner) :startset) (add-error scanner (str "Expected beginning of set: ${. Got " char next))) ;; struct @{ \@ (if (= next \{) - (add-token (advance scanner) ::token/startstruct) + (add-token (advance scanner) :startstruct) (add-error scanner (str "Expected beginning of struct: @{. Got " char next))) ;; placeholders ;; there's a flat _, and then ignored words \_ (cond - (terminates? next) (add-token scanner ::token/placeholder) + (terminates? next) (add-token scanner :placeholder) (alpha? next) (add-ignored scanner) :else (add-error scanner (str "Expected placeholder: _. Got " char next))) @@ -306,7 +306,7 @@ ;; splats \. (let [after_next (current-char (advance scanner))] (if (= ".." (str next after_next)) - (add-token (advance (advance scanner)) ::token/splat) + (add-token (advance (advance scanner)) :splat) (add-error scanner (str "Expected splat: ... . Got " (str "." next after_next))))) ;; strings @@ -321,14 +321,14 @@ :else (add-error scanner (str "Unexpected character: " char)))))) (defn- next-token [scanner] - (assoc scanner ::start (::current scanner))) + (assoc scanner :start (:current scanner))) (defn scan [source] (loop [scanner (new-scanner (str source "\n"))] (if (at-end? scanner) - (let [scanner (add-token scanner ::token/eof)] - {:tokens (::tokens scanner) - :errors (::errors scanner)}) + (let [scanner (add-token scanner :eof)] + {:tokens (:tokens scanner) + :errors (:errors scanner)}) (recur (-> scanner (scan-token) (next-token)))))) (scan "2 :three true nil") From d605cbd42a9d9c8ff1470db05eb42f05f0d9dd84 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Tue, 2 May 2023 19:06:37 -0400 Subject: [PATCH 02/43] unfuck merge --- project.clj | 6 ------ 1 file changed, 6 deletions(-) diff --git a/project.clj b/project.clj index a9696ab..d153482 100644 --- a/project.clj +++ b/project.clj @@ -4,12 +4,6 @@ :license {:name "EPL-2.0 OR GPL-2.0-or-later WITH Classpath-exception-2.0" :url "https://www.eclipse.org/legal/epl-2.0/"} :dependencies [[org.clojure/clojure "1.11.1"] -<<<<<<< HEAD - [babashka/fs "0.1.6"] - [quil "4.0.0-SNAPSHOT"]] -||||||| 1c2ab51 - [babashka/fs "0.1.6"]] -======= [babashka/fs "0.1.6"] [quil "4.0.0-SNAPSHOT-1"]] >>>>>>> 55d76f6854bf67119873d98e2c9c18d8390ab90a From 96b3f01e7e8426ecc203b179b40bdd8ada4160ff Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Tue, 2 May 2023 19:07:21 -0400 Subject: [PATCH 03/43] keep unfucking merge --- src/ludus/parser-new.clj | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 src/ludus/parser-new.clj diff --git a/src/ludus/parser-new.clj b/src/ludus/parser-new.clj new file mode 100644 index 0000000..53c09e7 --- /dev/null +++ b/src/ludus/parser-new.clj @@ -0,0 +1,7 @@ +(ns ludus.parser-new) + +(defn ok? [[ok]] + (= ok :ok)) + +(defn match [kw token] + ) \ No newline at end of file From 197f4772ba8557e476a1dc87088877b5488ca86c Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Tue, 2 May 2023 19:08:18 -0400 Subject: [PATCH 04/43] keep unfucking merge --- project.clj | 1 - 1 file changed, 1 deletion(-) diff --git a/project.clj b/project.clj index d153482..1e7b261 100644 --- a/project.clj +++ b/project.clj @@ -6,7 +6,6 @@ :dependencies [[org.clojure/clojure "1.11.1"] [babashka/fs "0.1.6"] [quil "4.0.0-SNAPSHOT-1"]] ->>>>>>> 55d76f6854bf67119873d98e2c9c18d8390ab90a :plugins [[lein-cljfmt "0.8.0"]] :repl-options {:init-ns ludus.core} :main ludus.core From 963c63aed34b5a320c68f140b8ee5220bb023a35 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Tue, 2 May 2023 19:15:05 -0400 Subject: [PATCH 05/43] Unwire the things for parser refactor --- src/ludus/core.clj | 8 ++++---- src/ludus/parser.clj | 4 ++-- src/ludus/prelude.clj | 6 +----- 3 files changed, 7 insertions(+), 11 deletions(-) diff --git a/src/ludus/core.clj b/src/ludus/core.clj index 72f4bbe..5ebf00c 100644 --- a/src/ludus/core.clj +++ b/src/ludus/core.clj @@ -11,7 +11,7 @@ (:gen-class)) (defn- run [file source] - (let [scanned (scanner/scan source)] +(comment (let [scanned (scanner/scan source)] (if (not-empty (:errors scanned)) (do (println "I found some scanning errors!") @@ -25,13 +25,13 @@ (System/exit 66)) (let [interpreted (interpreter/interpret parsed file)] (println (show/show interpreted)) - (System/exit 0))))))) + (System/exit 0)))))))) (defn -main [& args] - (cond +(comment (cond (= (count args) 1) (let [file (first args) source (loader/load-import file)] (run file source)) - :else (repl/launch))) \ No newline at end of file + :else (repl/launch)))) \ No newline at end of file diff --git a/src/ludus/parser.clj b/src/ludus/parser.clj index 9b1612e..7abfbff 100644 --- a/src/ludus/parser.clj +++ b/src/ludus/parser.clj @@ -1224,7 +1224,7 @@ (parser) (parse-script))) -(do +(comment (do (def my-source " data Foo {foo, bar} data Bar as { @@ -1234,7 +1234,7 @@ data Bar as { ") - (::ast (parse (scanner/scan my-source)))) + (::ast (parse (scanner/scan my-source))))) (comment " Further thoughts/still to do: diff --git a/src/ludus/prelude.clj b/src/ludus/prelude.clj index 4936f0a..d2fb63e 100644 --- a/src/ludus/prelude.clj +++ b/src/ludus/prelude.clj @@ -94,13 +94,9 @@ ::data/type ::data/clj :body get}) -(def draw {:name "draw" - ::data/type ::data/clj - :body draw/ludus-draw}) - (def draw {:name "draw" ::data/type ::data/clj - :body d/draw}) + :body d/ludus-draw}) (def prelude {"eq" eq "add" add From c5a72912df894ede607203a472c52bed44e03bf5 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Tue, 2 May 2023 19:43:57 -0400 Subject: [PATCH 06/43] Dequalify token keywords --- src/ludus/token.clj | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/ludus/token.clj b/src/ludus/token.clj index e156751..5188fbd 100644 --- a/src/ludus/token.clj +++ b/src/ludus/token.clj @@ -2,8 +2,8 @@ (defn token [type text literal line start] - {::type type - ::lexeme text - ::literal literal - ::line line - ::start start}) + {:type type + :lexeme text + :literal literal + :line line + :start start}) From 2866ff4eb62ff566a4e918b61dc5711827fbb142 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Tue, 2 May 2023 19:44:17 -0400 Subject: [PATCH 07/43] Make some modest moves --- src/ludus/parser-new.clj | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/src/ludus/parser-new.clj b/src/ludus/parser-new.clj index 53c09e7..d94bd41 100644 --- a/src/ludus/parser-new.clj +++ b/src/ludus/parser-new.clj @@ -1,7 +1,32 @@ -(ns ludus.parser-new) +(ns ludus.parser-new + (:require + [ludus.scanner :as scan])) (defn ok? [[ok]] (= ok :ok)) +(defn kw->type [kw] (apply str (next (str kw)))) + (defn match [kw token] - ) \ No newline at end of file + (if (= kw (:type token)) + [:ok token] + [:error token (str "Expected " (kw->type kw))])) + +(defn parser + ([kw] {:type kw :fn #(match kw %)}) + ([kw err] {:type kw :fn #(assoc (match kw %) 2 err)})) + + +(defn choice [& args]) + +(def eg (:tokens (scan/scan "123 :foo"))) + +(def word (parser :word "fuck")) + +(word (first eg)) + +(comment + +(def string (parser :string)) + +) \ No newline at end of file From 5b1ff5aef39ce2486ce3b79925e99815a7652891 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sun, 7 May 2023 22:49:19 -0400 Subject: [PATCH 08/43] Many iterations of parser combinator strategies. Not yet working. --- src/ludus/parser-new.clj | 231 ++++++++++++++++++++++++++++++++++++--- src/ludus/scanner.clj | 16 ++- tokens | 47 ++++++++ 3 files changed, 272 insertions(+), 22 deletions(-) create mode 100644 tokens diff --git a/src/ludus/parser-new.clj b/src/ludus/parser-new.clj index d94bd41..3536db5 100644 --- a/src/ludus/parser-new.clj +++ b/src/ludus/parser-new.clj @@ -1,32 +1,227 @@ (ns ludus.parser-new - (:require - [ludus.scanner :as scan])) + (:require + [ludus.scanner :as scan])) -(defn ok? [[ok]] - (= ok :ok)) +(def msgs { -(defn kw->type [kw] (apply str (next (str kw)))) + }) -(defn match [kw token] - (if (= kw (:type token)) - [:ok token] - [:error token (str "Expected " (kw->type kw))])) +(defn ? [val default] (if (nil? val) default val)) -(defn parser - ([kw] {:type kw :fn #(match kw %)}) - ([kw err] {:type kw :fn #(assoc (match kw %) 2 err)})) +(defn ok? [{status :status}] + (= status :ok)) +(defn pass? [{status :status}] (or (= status :ok) (= status :quiet))) -(defn choice [& args]) +(defn data [{d :data}] d) -(def eg (:tokens (scan/scan "123 :foo"))) +(defn remaining [{r :remaining}] r) -(def word (parser :word "fuck")) +(defn pname [parser] (? (:name parser) parser)) -(word (first eg)) +(defn value [token] + (if (= :none (:literal token)) (:lexeme token) (:literal token))) + +(defn apply-kw-parser [kw tokens] + (let [token (first tokens)] + (println "applying kw parser " kw " to " token) + (if (= kw (:type token)) + {:status :ok :type kw :data [(value token)] :token token :remaining (rest tokens)} + {:status :err :token token :trace [kw] :remaining (rest tokens)}))) + +(defn apply-fn-parser [parser tokens] + (println "applying fn parser" parser ", " tokens) + (let [rule (:rule parser) name (:name parser)] + (println "appying fn parser " name " to " (first tokens)) + (rule tokens))) + +(defn apply-parser [parser tokens] + (if (keyword? parser) + (apply-kw-parser parser tokens) + (apply-fn-parser parser tokens))) + +(defn pmap [f parser] (fn [tokens] (f (apply-parser parser tokens)))) + +(defn choice [name parsers] + {:name name + :rule (fn [tokens] + (println "entering CHOICE" name) + (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} + + (empty? rem-ps) + {:status :err :token (first tokens) :trace [name] :remaining rem-ts} + :else (recur rem-ps)))))}) + +(defn order [name parsers] + {:name name + :rule (fn [tokens] + (println "entering ORDER" name) + (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)) + (case (:status result) + + :ok {:status :ok + :type name + :data (conj results result) + :token origin + :remaining res-rem} + + :quiet {:status :ok + :type name + :data results + :token origin + :remaining res-rem} + + :group {:status :ok + :type name + :data (concat results (:data result)) + :token origin + :remaining res-rem} + + :err (update result :trace #(conj % name))) + + (case (:status result) + :ok (recur (rest ps) (conj results result) res-rem) + :group (recur (rest ps) + ;; TODO: fix this? + ;; This is supposed to undo the :quiet/:group thing + (concat results + (filter #(= (:status %) :ok) (:data result))) + res-rem) + :quiet (recur (rest ps) results res-rem) + :err (update result :trace #(conj % name))))))))}) + +(defn quiet [parser] + {:name (? (:name parser) parser) + :rule (fn [tokens] + (let [result (apply-parser parser tokens)] + (if (pass? result) + (assoc result :status :quiet) + result)))}) + +(defn one+ + ([parser] (one+ (pname parser) parser)) + ([name parser] + {:name name + :rule (fn [tokens] + (let [result (apply-parser parser tokens) + rest (zero+ name parser)] + (case (:status result) + (:ok :quiet) + (let [rest-result (apply-parser rest (remaining result)) + rest-data (data rest-result) + rest-remaining (remaining rest-result)] + (println rest-data) + {:status :group + :type name + :data (concat (data result) (second rest-data)) + :token (first tokens) + :remaining rest-remaining}) + + :err result)))})) + +(defn zero+ + ([parser] (zero+ (pname parser) parser)) + ([name parser] + {:name name + :rule (fn [tokens] + (println "entering ZERO+") + (loop [results [] + ts tokens + back tokens] + (println "looping ZERO+" (:name parser)) + (let [result (apply-parser parser ts)] + (if (pass? result) + (recur (conj results result) (remaining result) ts) + {:status :group :type name :data results :token (first tokens) :remaining ts} + ))))})) + +(defn maybe + ([parser] (maybe (pname parser) parser)) + ([name parser] + {:name name + :rule (fn [tokens] + (let [result (apply-parser parser tokens)] + (if (pass? result) + result + {:status :group :type name :data [] :token (first tokens) :remaining tokens} + )))})) (comment + "So one thing I'm thinking about is the fact that zero+, one+, maybe all only really make sense in the context of an `order` call. So that idea is that anything that's in one of these should be added to the `order`'s data vector, rather than putting it in a subordinate structure. -(def string (parser :string)) + This is much the same as the `quiet` idea: there should be some kind of internal representation of the thing. -) \ No newline at end of file + *** + + And now the `group` status has broken `quiet` + + +") + +(defn group + ([parser] (pname parser) parser) + ([name parser] (fn [tokens] + (let [result (apply-parser parser tokens) + data (map :data (:data result))] + {assoc result :data data})))) + + +(declare expression) + +(def literal (choice :literal [:nil :true :false :number :string :keyword])) + +(def separator (one+ (choice :separator [:comma :newline]))) + +(def nls? (quiet (zero+ :nls :newline))) + +(def tuple-entries (order :tuple-entries [(quiet separator) expression])) + +(def tuple (order :tuple + [(quiet :lparen) + (maybe expression) + (zero+ tuple-entries) + (quiet :rparen)])) + +(def expression (choice :expression [tuple literal])) + +(def foo (order :foo [:number :keyword])) + +(def eg (:tokens (scan/scan "(1, 2, 3)"))) + +(def result (apply-parser tuple eg)) + +result + +(defn clean [node] + (if (map? node) + (-> node + (dissoc + :status + :remaining + :token) + (update :data #(map clean %))) + node)) + +(defn tap [x] (println "\n\n\n\n******NEW PARSE\n\n:::=> " x "\n\n") x) + +(def my-data (-> result clean tap)) + +my-data + +(def my-first (-> my-data first)) + +(def my-sec (map :data (-> my-data second :data))) + +(concat my-first my-sec) \ No newline at end of file diff --git a/src/ludus/scanner.clj b/src/ludus/scanner.clj index 99d7967..9187d1f 100644 --- a/src/ludus/scanner.clj +++ b/src/ludus/scanner.clj @@ -11,20 +11,20 @@ "cond" :cond ;; impl "do" :do ;; impl "else" :else ;; impl - "false" :false ;; impl + "false" :false ;; impl -> literal word "fn" :fn ;; impl "if" :if ;; impl "import" :import ;; impl "let" :let ;; impl "loop" :loop ;; impl "match" :match ;; impl - "nil" :nil ;; impl + "nil" :nil ;; impl -> literal word "ns" :ns ;; impl ;; "panic!" :panic ;; impl (should be a function) "recur" :recur ;; impl "ref" :ref ;; impl "then" :then ;; impl - "true" :true ;; impl + "true" :true ;; impl -> literal word "with" :with ;; impl ;; actor model/concurrency @@ -42,6 +42,12 @@ ;; "module" :module ;; not necessary if we don't have datatypes }) +(def literal-words { + "true" true + "false" false + "nil" nil +}) + (defn- new-scanner "Creates a new scanner." [source] @@ -195,7 +201,9 @@ word (str char)] (let [curr (current-char scanner)] (cond - (terminates? curr) (add-token scanner (get reserved-words word :word)) + (terminates? curr) (add-token scanner + (get reserved-words word :word) + (get literal-words word :none)) (word-char? curr) (recur (advance scanner) (str word curr)) :else (add-error scanner (str "Unexpected " curr " after word " word ".")))))) diff --git a/tokens b/tokens new file mode 100644 index 0000000..23d11ef --- /dev/null +++ b/tokens @@ -0,0 +1,47 @@ +TOKENS: + +:nil +:true +:false +:word +:keyword +:number +:string + +:as +:cond +:do +:else +:fn +:if +:import +:let +:loop +:ref +:then +:with + +:receive +:spawn +:repeat +:test +:when + +:lparen +:rparen +:lbrace +:rbrace +:lbracket +:rbracket +:semicolon +:comma +:newline +:backslash +:equals +:pipeline +:rarrow +:startdict +:startstruct +:startset +:splat +:eof \ No newline at end of file From 919ab5ca340bc0fb5cdc75e23f3f258cd2dad279 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sun, 7 May 2023 23:23:42 -0400 Subject: [PATCH 09/43] Keep grinding on parser combinators --- src/ludus/parser-new.clj | 85 +++++++++++++++++++++++++++------------- 1 file changed, 58 insertions(+), 27 deletions(-) diff --git a/src/ludus/parser-new.clj b/src/ludus/parser-new.clj index 3536db5..4f597a3 100644 --- a/src/ludus/parser-new.clj +++ b/src/ludus/parser-new.clj @@ -85,7 +85,7 @@ :group {:status :ok :type name - :data (concat results (:data result)) + :data (vec (concat results (:data result))) :token origin :remaining res-rem} @@ -96,8 +96,8 @@ :group (recur (rest ps) ;; TODO: fix this? ;; This is supposed to undo the :quiet/:group thing - (concat results - (filter #(= (:status %) :ok) (:data result))) + (vec (concat results + (filter #(= (:status %) :ok) (:data result)))) res-rem) :quiet (recur (rest ps) results res-rem) :err (update result :trace #(conj % name))))))))}) @@ -110,27 +110,6 @@ (assoc result :status :quiet) result)))}) -(defn one+ - ([parser] (one+ (pname parser) parser)) - ([name parser] - {:name name - :rule (fn [tokens] - (let [result (apply-parser parser tokens) - rest (zero+ name parser)] - (case (:status result) - (:ok :quiet) - (let [rest-result (apply-parser rest (remaining result)) - rest-data (data rest-result) - rest-remaining (remaining rest-result)] - (println rest-data) - {:status :group - :type name - :data (concat (data result) (second rest-data)) - :token (first tokens) - :remaining rest-remaining}) - - :err result)))})) - (defn zero+ ([parser] (zero+ (pname parser) parser)) ([name parser] @@ -147,6 +126,27 @@ {:status :group :type name :data results :token (first tokens) :remaining ts} ))))})) +(defn one+ + ([parser] (one+ (pname parser) parser)) + ([name parser] + {:name name + :rule (fn [tokens] + (let [result (apply-parser parser tokens) + rest (zero+ name parser)] + (case (:status result) + (:ok :quiet) + (let [rest-result (apply-parser rest (remaining result)) + rest-data (data rest-result) + rest-remaining (remaining rest-result)] + (println rest-data) + {:status :group + :type name + :data (vec (concat (data result) (second rest-data)) ) + :token (first tokens) + :remaining rest-remaining}) + + :err result)))})) + (defn maybe ([parser] (maybe (pname parser) parser)) ([name parser] @@ -167,6 +167,8 @@ And now the `group` status has broken `quiet` + TODO: the concats put things into lists/seqs, and thus lett and iff are out of order. + ") @@ -186,6 +188,23 @@ (def nls? (quiet (zero+ :nls :newline))) +(def pattern (choice :pattern [:literal :word])) ;; stupid to start + +(def iff (order :iff [ + (quiet :if) nls? + expression + nls? (quiet :then) + expression + nls? (quiet :else) + expression])) + +(def lett (order :let [ + (quiet :let) + pattern + (quiet :equals) + nls? + expression])) + (def tuple-entries (order :tuple-entries [(quiet separator) expression])) (def tuple (order :tuple @@ -194,13 +213,25 @@ (zero+ tuple-entries) (quiet :rparen)])) -(def expression (choice :expression [tuple literal])) +(def synth-root (choice :synth-root [:keyword :word])) + +(def synth-term (choice :synth-term [:tuple :keyword])) + +(def synthetic (order :synthetic [synth-root (one+ synth-term)])) + +(def terminator (choice :terminator [:newline :semicolon])) + +(def block-line (order :block-line [(quiet terminator) expression])) + +(def block (order :block [(quiet :lbrace) nls? expression (zero+ block-line) nls? (quiet :rbrace)])) + +(def expression (choice :expression [tuple literal lett iff synthetic :word block])) (def foo (order :foo [:number :keyword])) -(def eg (:tokens (scan/scan "(1, 2, 3)"))) +(def eg (:tokens (scan/scan "let foo = :bar"))) -(def result (apply-parser tuple eg)) +(def result (apply-parser expression eg)) result From cbd78ce7f772cf500eeef3da35bb4c06783cbc89 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Tue, 16 May 2023 16:06:18 -0400 Subject: [PATCH 10/43] Get parser combinator strategy working --- src/ludus/parser-new.clj | 365 +++++++++++++++++++++++---------------- 1 file changed, 218 insertions(+), 147 deletions(-) diff --git a/src/ludus/parser-new.clj b/src/ludus/parser-new.clj index 4f597a3..801b942 100644 --- a/src/ludus/parser-new.clj +++ b/src/ludus/parser-new.clj @@ -2,16 +2,18 @@ (:require [ludus.scanner :as scan])) -(def msgs { - - }) - (defn ? [val default] (if (nil? val) default val)) (defn ok? [{status :status}] (= status :ok)) -(defn pass? [{status :status}] (or (= status :ok) (= status :quiet))) +(def failing #{:err :none}) + +(def passing #{:ok :group :silent}) + +(defn pass? [{status :status}] (contains? passing status)) + +(defn fail? [{status :status}] (conatins? failing status)) (defn data [{d :data}] d) @@ -19,205 +21,259 @@ (defn pname [parser] (? (:name parser) parser)) +(defn str-part [kw] (apply str (next (str kw)))) + +(defn kw+str [kw mystr] (keyword (str (str-part kw) mystr))) + (defn value [token] (if (= :none (:literal token)) (:lexeme token) (:literal token))) (defn apply-kw-parser [kw tokens] (let [token (first tokens)] - (println "applying kw parser " kw " to " token) + ;(println "applying kw parser " kw " to " token) (if (= kw (:type token)) - {:status :ok :type kw :data [(value token)] :token token :remaining (rest tokens)} - {:status :err :token token :trace [kw] :remaining (rest tokens)}))) + {:status :ok + :type kw + :data (if (value token) [(value token)] []) + :token token + :remaining (rest tokens)} + {:status :none :token token :trace [kw] :remaining (rest tokens)}))) (defn apply-fn-parser [parser tokens] - (println "applying fn parser" parser ", " tokens) (let [rule (:rule parser) name (:name parser)] - (println "appying fn parser " name " to " (first tokens)) + ;(println "appying fn parser " name " to " (first tokens)) (rule tokens))) (defn apply-parser [parser tokens] - (if (keyword? parser) - (apply-kw-parser parser tokens) - (apply-fn-parser parser tokens))) - -(defn pmap [f parser] (fn [tokens] (f (apply-parser parser tokens)))) + (cond + (keyword? parser) (apply-kw-parser parser tokens) + (:rule parser) (apply-fn-parser parser tokens) + :else (throw (Exception. "`apply-parser` requires a parser")))) (defn choice [name parsers] {:name name - :rule (fn [tokens] - (println "entering CHOICE" name) + :rule (fn choice-fn [tokens] + ;(println "entering CHOICE" name) (loop [ps parsers] (let [result (apply-parser (first ps) tokens) rem-ts (remaining result) rem-ps (rest ps)] - (cond + (cond (pass? result) {:status :ok :type name :data [result] :token (first tokens) :remaining rem-ts} + (= :err (:status result)) + (update result :trace #(conj % name)) + (empty? rem-ps) - {:status :err :token (first tokens) :trace [name] :remaining rem-ts} + {:status :none :token (first tokens) :trace [name] :remaining rem-ts} + :else (recur rem-ps)))))}) (defn order [name parsers] {:name name - :rule (fn [tokens] - (println "entering ORDER" name) - (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)) - (case (:status result) - - :ok {:status :ok - :type name - :data (conj results result) - :token origin - :remaining res-rem} - - :quiet {:status :ok - :type name - :data results - :token origin - :remaining res-rem} + :rule (fn order-fn [tokens] + ;(println "entering ORDER" name) + (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} - :group {:status :ok - :type name - :data (vec (concat results (:data result))) - :token origin - :remaining res-rem} + (:ok :quiet :group) + (loop [ps (rest parsers) + results (case (:status first-result) + :ok [first-result] + :quiet [] + :group (:data first-result)) + ts (remaining first-result)] + (let [result (apply-parser (first ps) ts) + res-rem (remaining result)] + (if (empty? (rest ps)) + (case (:status result) + :ok {:status :group + :type name + :data (conj results result) + :token origin + :remaining res-rem} - :err (update result :trace #(conj % name))) + :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) + (assoc (update result :trace #(conj % name)) :status :err)) - (case (:status result) - :ok (recur (rest ps) (conj results result) res-rem) - :group (recur (rest ps) - ;; TODO: fix this? - ;; This is supposed to undo the :quiet/:group thing - (vec (concat results - (filter #(= (:status %) :ok) (:data result)))) - res-rem) - :quiet (recur (rest ps) results res-rem) - :err (update result :trace #(conj % name))))))))}) + (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) + (assoc (update result :trace #(conj % name)) :status :err))))))))}) (defn quiet [parser] - {:name (? (:name parser) parser) - :rule (fn [tokens] + {:name (kw+str (? (:name parser) parser) "-quiet") + :rule (fn quiet-fn [tokens] (let [result (apply-parser parser tokens)] (if (pass? result) - (assoc result :status :quiet) - result)))}) + (assoc result :status :quiet) + result)))}) (defn zero+ - ([parser] (zero+ (pname parser) parser)) - ([name parser] - {:name name - :rule (fn [tokens] - (println "entering ZERO+") - (loop [results [] - ts tokens - back tokens] - (println "looping ZERO+" (:name parser)) - (let [result (apply-parser parser ts)] - (if (pass? result) - (recur (conj results result) (remaining result) ts) - {:status :group :type name :data results :token (first tokens) :remaining ts} - ))))})) + ([parser] (zero+ (pname parser) parser)) + ([name parser] + {:name (kw+str name "-zero+") + :rule (fn zero+fn [tokens] + ;(println "entering ZERO+") + (loop [results [] + ts tokens] + ;(println "looping ZERO+" (? (:name parser) parser)) + (let [result (apply-parser parser ts)] + (case (:status result) + :ok (recur (conj results result) (remaining result)) + :group (recur (vec (concat results (:data result))) (remaining result)) + :quiet (recur results (remaining result)) + {:status :group :type name :data results :token (first tokens) :remaining ts}))))})) (defn one+ - ([parser] (one+ (pname parser) parser)) - ([name parser] - {:name name - :rule (fn [tokens] - (let [result (apply-parser parser tokens) - rest (zero+ name parser)] - (case (:status result) - (:ok :quiet) - (let [rest-result (apply-parser rest (remaining result)) - rest-data (data rest-result) - rest-remaining (remaining rest-result)] - (println rest-data) - {:status :group - :type name - :data (vec (concat (data result) (second rest-data)) ) - :token (first tokens) - :remaining rest-remaining}) - - :err result)))})) + ([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 (:status first-result) + (:ok :group) + (let [rest-result (apply-parser rest-parser (remaining first-result))] + {:status :group + :type name + :data (vec (concat [first-result] (data rest-result))) + :token (first tokens) + :remaining (remaining rest-result)}) + + :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 name - :rule (fn [tokens] - (let [result (apply-parser parser tokens)] - (if (pass? result) - result - {:status :group :type name :data [] :token (first tokens) :remaining tokens} - )))})) + ([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} + )))})) (comment - "So one thing I'm thinking about is the fact that zero+, one+, maybe all only really make sense in the context of an `order` call. So that idea is that anything that's in one of these should be added to the `order`'s data vector, rather than putting it in a subordinate structure. + " + If I'm not mistaken, the Ludus grammer requires *no* lookahead, the first token in an expression tells you what kind of expression it is: - This is much the same as the `quiet` idea: there should be some kind of internal representation of the thing. + Rather, there is one ambiguity: synthetic expressions can start with words or keywords. + A bare word can be assimilated to synthetic expressions. Interestingly, so can synthetic. - *** + The parsing strategy is the same: consume as many things until you can't get anymore. - And now the `group` status has broken `quiet` + The fact that a bare keyword is evaluated like a literal doesn't matter. - TODO: the concats put things into lists/seqs, and thus lett and iff are out of order. + So: + literal -> literal + keyword -> synthetic + word -> synthetic + ( -> tuple + [ -> list + #{ -> dict + @{ -> struct + ns -> ns + let -> let + do -> pipeline + etc. -") + Because there's now NO lookahead, we can easily distinguish between orderings that don't match at all, and ones which match on the first token. -(defn group - ([parser] (pname parser) parser) - ([name parser] (fn [tokens] - (let [result (apply-parser parser tokens) - data (map :data (:data result))] - {assoc result :data data})))) + Because of that, we can also distinguish between no-match and errors + + ") (declare expression) -(def literal (choice :literal [:nil :true :false :number :string :keyword])) +(def literal (choice :literal [:nil :true :false :number :string])) -(def separator (one+ (choice :separator [:comma :newline]))) +(def separator (choice :separator [:comma :newline])) (def nls? (quiet (zero+ :nls :newline))) (def pattern (choice :pattern [:literal :word])) ;; stupid to start (def iff (order :iff [ - (quiet :if) nls? - expression - nls? (quiet :then) - expression - nls? (quiet :else) - expression])) + (quiet :if) + nls? + expression + nls? + (quiet :then) + expression + nls? + (quiet :else) + expression])) (def lett (order :let [ - (quiet :let) - pattern - (quiet :equals) - nls? - expression])) + (quiet :let) + pattern + (quiet :equals) + nls? + expression])) -(def tuple-entries (order :tuple-entries [(quiet separator) expression])) +(def tuple-entry (order :tuple-entry [(quiet (one+ separator)) expression])) (def tuple (order :tuple - [(quiet :lparen) - (maybe expression) - (zero+ tuple-entries) - (quiet :rparen)])) + [(quiet :lparen) + (quiet (zero+ separator)) + (maybe expression) + (zero+ tuple-entry) + (quiet (zero+ separator)) + (quiet :rparen)])) + +(def splat (order :splat [(quiet :splat) :word])) + +(def list-term (choice :list-term [splat expression])) + +(def list-entry (order :list-entry [(quiet (one+ separator)) list-term])) + +(def listt (order :list + [(quiet :lbracket) + (quiet (zero+ separator)) + (maybe list-term) + (zero+ list-entry) + (quiet (zero+ separator)) + (quiet :rbracket)])) (def synth-root (choice :synth-root [:keyword :word])) -(def synth-term (choice :synth-term [:tuple :keyword])) +(def synth-term (choice :synth-term [tuple :keyword])) -(def synthetic (order :synthetic [synth-root (one+ synth-term)])) +(def synthetic (order :synthetic [synth-root (zero+ synth-term)])) (def terminator (choice :terminator [:newline :semicolon])) @@ -225,25 +281,40 @@ (def block (order :block [(quiet :lbrace) nls? expression (zero+ block-line) nls? (quiet :rbrace)])) -(def expression (choice :expression [tuple literal lett iff synthetic :word block])) +(def expression (choice :expression [lett iff synthetic block listt tuple literal])) -(def foo (order :foo [:number :keyword])) +(def importt (order :import [(quiet :import) :string (quiet :as) :word])) -(def eg (:tokens (scan/scan "let foo = :bar"))) +(def toplevel (choice :toplevel [importt expression])) -(def result (apply-parser expression eg)) +(def script-line (order :script-line [(quiet terminator) toplevel])) + +(def script (order :script [nls? toplevel (zero+ script-line) nls? (quiet :eof)])) + + +(def eg (:tokens (scan/scan + "" + ))) + +eg + +(println eg) + +(def result (apply-parser script eg)) result +(println result) + (defn clean [node] - (if (map? node) - (-> node - (dissoc - :status - :remaining - :token) - (update :data #(map clean %))) - node)) + (if (map? node) + (-> node + (dissoc + :status + :remaining + :token) + (update :data #(into [] (map clean) %))) + node)) (defn tap [x] (println "\n\n\n\n******NEW PARSE\n\n:::=> " x "\n\n") x) From 52abde501a423f5130d1582a2914451958759c80 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Tue, 16 May 2023 18:29:22 -0400 Subject: [PATCH 11/43] Add flat combinator --- src/ludus/parser-new.clj | 42 +++++++++++++++++++++++++--------------- 1 file changed, 26 insertions(+), 16 deletions(-) diff --git a/src/ludus/parser-new.clj b/src/ludus/parser-new.clj index 801b942..f2af225 100644 --- a/src/ludus/parser-new.clj +++ b/src/ludus/parser-new.clj @@ -13,7 +13,7 @@ (defn pass? [{status :status}] (contains? passing status)) -(defn fail? [{status :status}] (conatins? failing status)) +(defn fail? [{status :status}] (contains? failing status)) (defn data [{d :data}] d) @@ -59,7 +59,7 @@ rem-ts (remaining result) rem-ps (rest ps)] (cond - (pass? result) + (pass? result) ;result {:status :ok :type name :data [result] :token (first tokens) :remaining rem-ts} (= :err (:status result)) @@ -86,9 +86,9 @@ (:ok :quiet :group) (loop [ps (rest parsers) results (case (:status first-result) - :ok [first-result] - :quiet [] - :group (:data first-result)) + :ok [first-result] + :quiet [] + :group (:data first-result)) ts (remaining first-result)] (let [result (apply-parser (first ps) ts) res-rem (remaining result)] @@ -164,13 +164,13 @@ :token (first tokens) :remaining (remaining rest-result)}) - :quiet - (let [rest-result (apply-parser rest-parser (remaining first-result))] - {:status :quiet - :type name - :data [] - :token (first tokens) - :remaining (remaining rest-result)}) + :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)))})) @@ -185,6 +185,14 @@ {: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 (:data result)) result)))})) + (comment " If I'm not mistaken, the Ludus grammer requires *no* lookahead, the first token in an expression tells you what kind of expression it is: @@ -219,7 +227,7 @@ (declare expression) -(def literal (choice :literal [:nil :true :false :number :string])) +(def literal (flat (choice :literal [:nil :true :false :number :string]))) (def separator (choice :separator [:comma :newline])) @@ -257,7 +265,7 @@ (def splat (order :splat [(quiet :splat) :word])) -(def list-term (choice :list-term [splat expression])) +(def list-term (flat (choice :list-term [splat expression]))) (def list-entry (order :list-entry [(quiet (one+ separator)) list-term])) @@ -285,7 +293,7 @@ (def importt (order :import [(quiet :import) :string (quiet :as) :word])) -(def toplevel (choice :toplevel [importt expression])) +(def toplevel (flat (choice :toplevel [importt expression]))) (def script-line (order :script-line [(quiet terminator) toplevel])) @@ -293,7 +301,9 @@ (def eg (:tokens (scan/scan - "" + "1 + 2 + 3" ))) eg From a7ab313a5f20ccc6b5d08ca622440e5fb6153b17 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Tue, 16 May 2023 20:54:01 -0400 Subject: [PATCH 12/43] Broken! Argh. --- src/ludus/grammar.clj | 212 +++++++++++++++++++ src/ludus/{parser-new.clj => parser_new.clj} | 143 ++----------- 2 files changed, 231 insertions(+), 124 deletions(-) create mode 100644 src/ludus/grammar.clj rename src/ludus/{parser-new.clj => parser_new.clj} (68%) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj new file mode 100644 index 0000000..abf1a71 --- /dev/null +++ b/src/ludus/grammar.clj @@ -0,0 +1,212 @@ +(ns ludus.grammar + (:require [ludus.parser-new :refer :all] + [ludus.scanner :as scan])) + +(declare expression pattern) + +(def separator (choice :separator [:comma :newline])) + +(def terminator (choice :terminator [:newline :semicolon])) + +(def nls? (quiet (zero+ :nls :newline))) + +(def splat (group (order :splat [(quiet :splat) :word]))) + +(def splattern (group (order :splat [(quiet :splattern) (flat (choice :splatted [:word :ignored :placeholder]))]))) + +(def literal (flat (choice :literal [:nil :true :false :number :string]))) + +(def tuple-pat-term (choice :tuple-pat-term [pattern splattern])) + +(def tuple-pat-entry (order :tuple-pat-enry [(quiet (one+ separator)) pattern])) + +(def tuple-pat (group (order :tuple-pat + [(quiet :lparen) + (quiet (zero+ separator)) + (maybe pattern) + (zero+ tuple-pat-entry) + (quiet (zero+ separator)) + (quiet :rparen)]))) + +;; TODO: list, dict, struct patterns + +(def pattern (choice :pattern [:literal :ignored :placeholder :word :keyword tuple-pat])) + +(def iff (order :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 (order :cond-clause [cond-lhs (quiet :rarrow) expression]))) + +(def cond-entry (order :cond-entry [(quiet (one+ terminator)) cond-clause])) + +(def condd (order :cond [(quiet :cond) (quiet :lbrace) + (quiet (zero+ terminator)) + cond-clause + (zero+ cond-entry) + (quiet (zero+ terminator)) + (quiet :rbrace)])) + +(def lett (order :let [(quiet :let) + pattern + (quiet :equals) + nls? + expression])) + +(def tuple-entry (order :tuple-entry [(quiet (one+ separator)) expression])) + +(def tuple (order :tuple + [(quiet :lparen) + (quiet (zero+ separator)) + (maybe expression) + (zero+ tuple-entry) + (quiet (zero+ separator)) + (quiet :rparen)])) + +(def list-term (flat (choice :list-term [splat expression]))) + +(def list-entry (order :list-entry [(quiet (one+ separator)) list-term])) + +(def listt (order :list + [(quiet :lbracket) + (quiet (zero+ separator)) + (maybe list-term) + (zero+ list-entry) + (quiet (zero+ separator)) + (quiet :rbracket)])) + +(def pair (group (order :pair [:keyword expression]))) + +(def struct-term (flat (choice :struct-term [:word pair]))) + +(def struct-entry (order :struct-entry [(quiet (one+ separator)) struct-term])) + +(def structt (order :struct + [(quiet :startstruct) + (quiet (zero+ separator)) + (maybe struct-term) + (zero+ struct-entry) + (quiet (zero+ separator)) + (quiet :rbrace)])) + +(def dict-term (flat (choice :dict-term [:word pair splat]))) + +(def dict-entry (order :dict-entry [(quiet (one+ separator)) dict-term])) + +(def dict (order :dict + [(quiet :startdict) + (quiet (zero+ separator)) + (maybe dict-term) + (zero+ dict-entry) + (quiet (zero+ separator)) + (quiet :rbrace)])) + +(def arg-expr (flat (choice :arg-expr [:placeholder expression]))) + +(def arg-entry (order :arg-entry [(quiet (one+ separator)) arg-expr])) + +(def arg-tuple (order :arg-tuple + [(quiet :lparen) + (quiet (zero+ separator)) + (maybe arg-expr) + (zero+ arg-entry) + (quiet (zero+ separator)) + (quiet :rparen)])) + +(def synth-root (choice :synth-root [:keyword :word :recur])) + +(def synth-term (choice :synth-term [arg-tuple :keyword])) + +(def synthetic (order :synthetic [synth-root (zero+ synth-term)])) + +(def fn-clause (group (order :fn-clause [tuple-pat (quiet :rarrow) expression]))) + +(def fn-entry (order :fn-entry [(quiet (one+ terminator)) fn-clause])) + +(def compound (group (order :compound [(quiet :lbrace) + (maybe :string) + fn-clause + (zero+ fn-entry) + nls? + (quiet :rbrace) + ]))) + +(def clauses (flat (choice :clauses [compound fn-clause]))) + +(def named (group (order :named [:word clauses]))) + +(def body (flat (choice :body [fn-clause named]))) + +(def fnn (group (order :fn [(quiet :fn) body]))) + +(def block-line (order :block-line [(quiet terminator) expression])) + +(def block (group (order :block [(quiet :lbrace) nls? expression (zero+ block-line) nls? (quiet :rbrace)]))) + +(def expression (flat (choice :expression [fnn lett iff condd synthetic block structt listt tuple literal]))) + +(def importt (group (order :import [(quiet :import) :string (quiet :as) :word]))) + +(def nss (group (order :nss [(quiet :ns) + :word + (quiet :lbrace) + (quiet (zero+ separator)) + (maybe struct-term) + (zero+ struct-entry) + (quiet (zero+ separator)) + (quiet :rbrace)]))) + +(def toplevel (flat (choice :toplevel [importt nss expression]))) + +(def script-line (order :script-line [(quiet (one+ terminator)) toplevel])) + +(def script (order :script [nls? toplevel (zero+ script-line) nls? (quiet :eof)])) + + +;;;;;;;;;;;;;;;; REPL CRUFT + +(def eg (:tokens (scan/scan + " +add (1, 2) +fn foo { (_) -> (1, 2) }" + ))) + + + +(def result (apply-parser script eg)) + + +(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 tap [x] (println "\n\n\n\n******NEW PARSE\n\n:::=> " x "\n\n") x) + +(def my-data (-> result clean tap)) + +my-data + +(def my-first (-> my-data first)) + +(def my-sec (map :data (-> my-data second :data))) + +(concat my-first my-sec) \ No newline at end of file diff --git a/src/ludus/parser-new.clj b/src/ludus/parser_new.clj similarity index 68% rename from src/ludus/parser-new.clj rename to src/ludus/parser_new.clj index f2af225..d1a8f5c 100644 --- a/src/ludus/parser-new.clj +++ b/src/ludus/parser_new.clj @@ -1,6 +1,4 @@ -(ns ludus.parser-new - (:require - [ludus.scanner :as scan])) +(ns ludus.parser-new) (defn ? [val default] (if (nil? val) default val)) @@ -30,7 +28,6 @@ (defn apply-kw-parser [kw tokens] (let [token (first tokens)] - ;(println "applying kw parser " kw " to " token) (if (= kw (:type token)) {:status :ok :type kw @@ -40,8 +37,7 @@ {:status :none :token token :trace [kw] :remaining (rest tokens)}))) (defn apply-fn-parser [parser tokens] - (let [rule (:rule parser) name (:name parser)] - ;(println "appying fn parser " name " to " (first tokens)) + (let [rule (:rule parser) name (:name parser)] (rule tokens))) (defn apply-parser [parser tokens] @@ -53,13 +49,12 @@ (defn choice [name parsers] {:name name :rule (fn choice-fn [tokens] - ;(println "entering CHOICE" name) (loop [ps parsers] (let [result (apply-parser (first ps) tokens) rem-ts (remaining result) rem-ps (rest ps)] (cond - (pass? result) ;result + (pass? result) {:status :ok :type name :data [result] :token (first tokens) :remaining rem-ts} (= :err (:status result)) @@ -72,8 +67,7 @@ (defn order [name parsers] {:name name - :rule (fn order-fn [tokens] - ;(println "entering ORDER" name) + :rule (fn order-fn [tokens] (let [origin (first tokens) first-result (apply-parser (first parsers) tokens)] (case (:status first-result) @@ -137,15 +131,14 @@ ([name parser] {:name (kw+str name "-zero+") :rule (fn zero+fn [tokens] - ;(println "entering ZERO+") (loop [results [] ts tokens] - ;(println "looping ZERO+" (? (:name parser) parser)) (let [result (apply-parser parser ts)] (case (:status result) :ok (recur (conj results result) (remaining result)) :group (recur (vec (concat results (:data result))) (remaining result)) :quiet (recur results (remaining result)) + :err (update result :trace #(conj % name)) {:status :group :type name :data results :token (first tokens) :remaining ts}))))})) (defn one+ @@ -193,6 +186,20 @@ (let [result (apply-parser parser tokens)] (if (pass? result) (first (:data result)) 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 (:status result)) + (assoc result :status :ok) + result)))})) + +(defn err-msg [{token :token trace :trace}] + (println "Unexpected token " (:type token) " on line " (:line token)) + (println "Expected token " (first trace))) + (comment " If I'm not mistaken, the Ludus grammer requires *no* lookahead, the first token in an expression tells you what kind of expression it is: @@ -225,115 +232,3 @@ ") -(declare expression) - -(def literal (flat (choice :literal [:nil :true :false :number :string]))) - -(def separator (choice :separator [:comma :newline])) - -(def nls? (quiet (zero+ :nls :newline))) - -(def pattern (choice :pattern [:literal :word])) ;; stupid to start - -(def iff (order :iff [ - (quiet :if) - nls? - expression - nls? - (quiet :then) - expression - nls? - (quiet :else) - expression])) - -(def lett (order :let [ - (quiet :let) - pattern - (quiet :equals) - nls? - expression])) - -(def tuple-entry (order :tuple-entry [(quiet (one+ separator)) expression])) - -(def tuple (order :tuple - [(quiet :lparen) - (quiet (zero+ separator)) - (maybe expression) - (zero+ tuple-entry) - (quiet (zero+ separator)) - (quiet :rparen)])) - -(def splat (order :splat [(quiet :splat) :word])) - -(def list-term (flat (choice :list-term [splat expression]))) - -(def list-entry (order :list-entry [(quiet (one+ separator)) list-term])) - -(def listt (order :list - [(quiet :lbracket) - (quiet (zero+ separator)) - (maybe list-term) - (zero+ list-entry) - (quiet (zero+ separator)) - (quiet :rbracket)])) - -(def synth-root (choice :synth-root [:keyword :word])) - -(def synth-term (choice :synth-term [tuple :keyword])) - -(def synthetic (order :synthetic [synth-root (zero+ synth-term)])) - -(def terminator (choice :terminator [:newline :semicolon])) - -(def block-line (order :block-line [(quiet terminator) expression])) - -(def block (order :block [(quiet :lbrace) nls? expression (zero+ block-line) nls? (quiet :rbrace)])) - -(def expression (choice :expression [lett iff synthetic block listt tuple literal])) - -(def importt (order :import [(quiet :import) :string (quiet :as) :word])) - -(def toplevel (flat (choice :toplevel [importt expression]))) - -(def script-line (order :script-line [(quiet terminator) toplevel])) - -(def script (order :script [nls? toplevel (zero+ script-line) nls? (quiet :eof)])) - - -(def eg (:tokens (scan/scan - "1 - 2 - 3" - ))) - -eg - -(println eg) - -(def result (apply-parser script eg)) - -result - -(println result) - -(defn clean [node] - (if (map? node) - (-> node - (dissoc - :status - :remaining - :token) - (update :data #(into [] (map clean) %))) - node)) - -(defn tap [x] (println "\n\n\n\n******NEW PARSE\n\n:::=> " x "\n\n") x) - -(def my-data (-> result clean tap)) - -my-data - -(def my-first (-> my-data first)) - -(def my-sec (map :data (-> my-data second :data))) - -(concat my-first my-sec) \ No newline at end of file From 23e29fdca29191f50a400ee934590c6642919145 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Thu, 18 May 2023 16:44:14 -0400 Subject: [PATCH 13/43] Reindent --- src/ludus/scanner.clj | 50 +++++++++++++++++++++---------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/ludus/scanner.clj b/src/ludus/scanner.clj index 9187d1f..dc80ca9 100644 --- a/src/ludus/scanner.clj +++ b/src/ludus/scanner.clj @@ -1,8 +1,8 @@ (ns ludus.scanner (:require - [ludus.token :as token] - ;; [clojure.pprint :as pp] - [clojure.edn :as edn])) + [ludus.token :as token] + ;; [clojure.pprint :as pp] + [clojure.edn :as edn])) (def reserved-words "List of Ludus reserved words." @@ -43,10 +43,10 @@ }) (def literal-words { - "true" true - "false" false - "nil" nil -}) + "true" true + "false" false + "nil" nil + }) (defn- new-scanner "Creates a new scanner." @@ -85,8 +85,8 @@ (defn- char-in-range? [start end char] (and char - (>= (int char) (int start)) - (<= (int char) (int end)))) + (>= (int char) (int start)) + (<= (int char) (int end)))) (defn- digit? [c] (char-in-range? \0 \9 c)) @@ -127,27 +127,27 @@ (add-token scanner token-type nil)) ([scanner token-type literal] (update scanner :tokens conj - (token/token - token-type - (current-lexeme scanner) - literal - (:line scanner) - (:start scanner))))) + (token/token + token-type + (current-lexeme scanner) + literal + (:line scanner) + (:start scanner))))) ;; TODO: errors should also be in the vector of tokens ;; The goal is to be able to be able to hand this to an LSP? ;; Do we need a different structure (defn- add-error [scanner msg] (let [token (token/token - :error - (current-lexeme scanner) - nil - (:line scanner) - (:start scanner)) + :error + (current-lexeme scanner) + nil + (:line scanner) + (:start scanner)) err-token (assoc token :message msg)] (-> scanner - (update :errors conj err-token) - (update :tokens conj err-token)))) + (update :errors conj err-token) + (update :tokens conj err-token)))) (defn- add-keyword [scanner] @@ -202,8 +202,8 @@ (let [curr (current-char scanner)] (cond (terminates? curr) (add-token scanner - (get reserved-words word :word) - (get literal-words word :none)) + (get reserved-words word :word) + (get literal-words word :none)) (word-char? curr) (recur (advance scanner) (str word curr)) :else (add-error scanner (str "Unexpected " curr " after word " word ".")))))) @@ -332,7 +332,7 @@ (assoc scanner :start (:current scanner))) (defn scan [source] - (loop [scanner (new-scanner (str source "\n"))] + (loop [scanner (new-scanner source)] (if (at-end? scanner) (let [scanner (add-token scanner :eof)] {:tokens (:tokens scanner) From f97453b8136860bf9774fd0ca22018279333d897 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Thu, 18 May 2023 16:44:29 -0400 Subject: [PATCH 14/43] Complete parser & ludus grammar! --- src/ludus/grammar.clj | 280 +++++++++++++++++++++++++++++---------- src/ludus/parser_new.clj | 23 +++- 2 files changed, 227 insertions(+), 76 deletions(-) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index abf1a71..23dc653 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -8,29 +8,78 @@ (def terminator (choice :terminator [:newline :semicolon])) +(defn entries [name sep parser] + (zero+ (weak (order name [(quiet (one+ sep)) parser])))) + (def nls? (quiet (zero+ :nls :newline))) (def splat (group (order :splat [(quiet :splat) :word]))) -(def splattern (group (order :splat [(quiet :splattern) (flat (choice :splatted [:word :ignored :placeholder]))]))) +(def splattern (group (order :splat [(quiet :splat) (flat (choice :splatted [:word :ignored :placeholder]))]))) (def literal (flat (choice :literal [:nil :true :false :number :string]))) -(def tuple-pat-term (choice :tuple-pat-term [pattern splattern])) +(def tuple-pattern-term (choice :tuple-pattern-term [pattern splattern])) -(def tuple-pat-entry (order :tuple-pat-enry [(quiet (one+ separator)) pattern])) +(def tuple-pattern-entries (entries :tuple-pattern-enries separator pattern)) -(def tuple-pat (group (order :tuple-pat - [(quiet :lparen) - (quiet (zero+ separator)) - (maybe pattern) - (zero+ tuple-pat-entry) - (quiet (zero+ separator)) - (quiet :rparen)]))) +(def tuple-pattern (group (order :tuple-pattern + [(quiet :lparen) + (quiet (zero+ separator)) + (maybe pattern) + tuple-pattern-entries + (quiet (zero+ separator)) + (quiet :rparen)]))) -;; TODO: list, dict, struct patterns +(def list-pattern (group (order :list-pattern + [(quiet :lbracket) + (quiet (zero+ separator)) + (maybe pattern) + tuple-pattern-entries + (quiet (zero+ separator)) + (quiet :rbracket)]))) -(def pattern (choice :pattern [:literal :ignored :placeholder :word :keyword tuple-pat])) +(def pair-pattern (order :pair-pattern [:keyword pattern])) + +(def dict-pattern-term (flat (choice :dict-pattern-term [pair-pattern :word splattern]))) + +(def dict-pattern-entries (entries :dict-pattern-entries separator dict-pattern-term)) + +(def dict-pattern (group (order :dict-pattern + [(quiet :startdict) + (quiet (zero+ separator)) + (maybe dict-pattern-term) + dict-pattern-entries + (quiet (zero+ separator)) + (quiet :rbrace) + ]))) + +(def struct-pattern (group (order :struct-pattern + [(quiet :startstruct) + (quiet (zero+ separator)) + (maybe dict-pattern-term) + dict-pattern-entries + (quiet (zero+ separator)) + (quiet :rbrace) + ]))) + +(def constraint (order :constraint [:when expression])) + +(def pattern (choice :pattern [literal :ignored :placeholder :word :keyword tuple-pattern dict-pattern struct-pattern list-pattern])) + +(def match-clause (group (order :match-clause + [pattern (maybe constraint) (quiet :rarrow) expression]))) + +(def match-entries (entries :match-entries terminator match-clause)) + +(def match (group (order :match + [(quiet :match) expression nls? + (quiet :with) (quiet :lbrace) nls? + match-clause + match-entries + nls? + (quiet :rbrace) + ]))) (def iff (order :if [(quiet :if) nls? @@ -46,78 +95,96 @@ (def cond-clause (group (order :cond-clause [cond-lhs (quiet :rarrow) expression]))) -(def cond-entry (order :cond-entry [(quiet (one+ terminator)) cond-clause])) +(def cond-entries (entries :cond-entries terminator cond-clause)) (def condd (order :cond [(quiet :cond) (quiet :lbrace) (quiet (zero+ terminator)) cond-clause - (zero+ cond-entry) + cond-entries (quiet (zero+ terminator)) (quiet :rbrace)])) -(def lett (order :let [(quiet :let) - pattern - (quiet :equals) - nls? - expression])) +(def lett (group (order :let [(quiet :let) + pattern + (quiet :equals) + nls? + expression]))) -(def tuple-entry (order :tuple-entry [(quiet (one+ separator)) expression])) +(def tuple-entry (weak (order :tuple-entry [(quiet (one+ separator)) expression]))) -(def tuple (order :tuple - [(quiet :lparen) - (quiet (zero+ separator)) - (maybe expression) - (zero+ tuple-entry) - (quiet (zero+ separator)) - (quiet :rparen)])) +(def tuple-entries (entries :tuple-entries separator expression)) + +(def tuple (group (order :tuple + [(quiet :lparen) + (quiet (zero+ separator)) + (maybe expression) + tuple-entries + (quiet (zero+ separator)) + (quiet :rparen)]))) (def list-term (flat (choice :list-term [splat expression]))) -(def list-entry (order :list-entry [(quiet (one+ separator)) list-term])) +(def list-entry (weak (order :list-entry [(quiet (one+ separator)) list-term]))) -(def listt (order :list - [(quiet :lbracket) - (quiet (zero+ separator)) - (maybe list-term) - (zero+ list-entry) - (quiet (zero+ separator)) - (quiet :rbracket)])) +(def list-entries (entries :list-entries separator list-term)) + +(def listt (group (order :list + [(quiet :lbracket) + (quiet (zero+ separator)) + (maybe list-term) + list-entries + (quiet (zero+ separator)) + (quiet :rbracket)]))) + +(def sett (group (order :set [ + (quiet :startset) + (quiet (zero+ separator)) + (maybe list-term) + list-entries + (quiet (zero+ separator)) + (quiet :rbrace)]))) (def pair (group (order :pair [:keyword expression]))) (def struct-term (flat (choice :struct-term [:word pair]))) -(def struct-entry (order :struct-entry [(quiet (one+ separator)) struct-term])) +(def struct-entry (weak (order :struc-entry [(quiet (one+ separator)) struct-term]))) -(def structt (order :struct - [(quiet :startstruct) - (quiet (zero+ separator)) - (maybe struct-term) - (zero+ struct-entry) - (quiet (zero+ separator)) - (quiet :rbrace)])) +(def struct-entries (entries :struct-entries separator struct-term)) + +(def structt (group (order :struct + [(quiet :startstruct) + (quiet (zero+ separator)) + (maybe struct-term) + struct-entries + (quiet (zero+ separator)) + (quiet :rbrace)]))) (def dict-term (flat (choice :dict-term [:word pair splat]))) -(def dict-entry (order :dict-entry [(quiet (one+ separator)) dict-term])) +(def dict-entry (weak (order :dict-entry [(quiet (one+ separator)) dict-term]))) -(def dict (order :dict - [(quiet :startdict) - (quiet (zero+ separator)) - (maybe dict-term) - (zero+ dict-entry) - (quiet (zero+ separator)) - (quiet :rbrace)])) +(def dict-entries (entries :dict-entries separator dict-term)) + +(def dict (group (order :dict + [(quiet :startdict) + (quiet (zero+ separator)) + (maybe dict-term) + dict-entries + (quiet (zero+ separator)) + (quiet :rbrace)]))) (def arg-expr (flat (choice :arg-expr [:placeholder expression]))) -(def arg-entry (order :arg-entry [(quiet (one+ separator)) arg-expr])) +(def arg-entry (weak (order :arg-entry [(quiet (one+ separator)) arg-expr]))) + +(def arg-entries (entries :arg-entries separator arg-expr)) (def arg-tuple (order :arg-tuple [(quiet :lparen) (quiet (zero+ separator)) (maybe arg-expr) - (zero+ arg-entry) + arg-entries (quiet (zero+ separator)) (quiet :rparen)])) @@ -127,14 +194,18 @@ (def synthetic (order :synthetic [synth-root (zero+ synth-term)])) -(def fn-clause (group (order :fn-clause [tuple-pat (quiet :rarrow) expression]))) +(def fn-clause (group (order :fn-clause [tuple-pattern (maybe constraint) (quiet :rarrow) expression]))) -(def fn-entry (order :fn-entry [(quiet (one+ terminator)) fn-clause])) +(def fn-entry (weak (order :fn-entry [(quiet (one+ terminator)) fn-clause]))) + +(def fn-entries (entries :fn-entries terminator fn-clause)) (def compound (group (order :compound [(quiet :lbrace) + nls? (maybe :string) + nls? fn-clause - (zero+ fn-entry) + fn-entries nls? (quiet :rbrace) ]))) @@ -147,11 +218,68 @@ (def fnn (group (order :fn [(quiet :fn) body]))) -(def block-line (order :block-line [(quiet terminator) expression])) +(def block-lines (entries :block-lines terminator expression)) -(def block (group (order :block [(quiet :lbrace) nls? expression (zero+ block-line) nls? (quiet :rbrace)]))) +(def block (group (order :block [(quiet :lbrace) + nls? + expression + block-lines + nls? (quiet :rbrace)]))) -(def expression (flat (choice :expression [fnn lett iff condd synthetic block structt listt tuple literal]))) +(def pipeline (order :pipeline [nls? :pipeline])) + +(def do-entry (weak (order :do-entry [pipeline expression]))) + +(def doo (group (order :do [ + (quiet :do) + expression + (one+ do-entry) + ]))) + +(def reff (group (order :ref [(quiet :ref) :word (quiet :equals) expression]))) + +(def spawn (group (order :spawn [(quiet :spawn) expression]))) + +(def receive (group (order :receive + [(quiet :receive) (quiet :lbrace) nls? + match-clause + match-entries + nls? + (quiet :rbrace) + ]))) + +(def compound-loop (group (order :compound-loop + [(quiet :lbrace) + nls? + fn-clause + fn-entries + nls? + (quiet :rbrace)]))) + +(def loopp (group (order :loop + [(quiet :loop) tuple (quiet :with) + (flat (choice :loop-body [fn-clause compound-loop]))]))) + +(def expression (flat (choice :expression [fnn + match + loopp + lett + iff + condd + spawn + receive + synthetic + block + doo + reff + structt + dict + listt + sett + tuple + literal]))) + +(def test (group (order :test [(quiet :test) :string expression]))) (def importt (group (order :import [(quiet :import) :string (quiet :as) :word]))) @@ -164,19 +292,28 @@ (quiet (zero+ separator)) (quiet :rbrace)]))) -(def toplevel (flat (choice :toplevel [importt nss expression]))) +(def toplevel (flat (choice :toplevel [importt nss expression test]))) -(def script-line (order :script-line [(quiet (one+ terminator)) toplevel])) +(def script-lines (entries :script-lines terminator toplevel)) -(def script (order :script [nls? toplevel (zero+ script-line) nls? (quiet :eof)])) +(def script (order :script [nls? + toplevel + script-lines + nls? + (quiet :eof)])) ;;;;;;;;;;;;;;;; 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 + + (def eg (:tokens (scan/scan - " -add (1, 2) -fn foo { (_) -> (1, 2) }" + "receive { _ -> 1; () -> 2 } + " ))) @@ -201,12 +338,9 @@ fn foo { (_) -> (1, 2) }" (defn tap [x] (println "\n\n\n\n******NEW PARSE\n\n:::=> " x "\n\n") x) -(def my-data (-> result clean tap)) +(def my-data (-> result + clean + tap + )) -my-data - -(def my-first (-> my-data first)) - -(def my-sec (map :data (-> my-data second :data))) - -(concat my-first my-sec) \ No newline at end of file +my-data \ No newline at end of file diff --git a/src/ludus/parser_new.clj b/src/ludus/parser_new.clj index d1a8f5c..8cef82b 100644 --- a/src/ludus/parser_new.clj +++ b/src/ludus/parser_new.clj @@ -28,6 +28,7 @@ (defn apply-kw-parser [kw tokens] (let [token (first tokens)] + (if (= kw (:type token)) (println "Matched " kw)) (if (= kw (:type token)) {:status :ok :type kw @@ -37,10 +38,12 @@ {:status :none :token token :trace [kw] :remaining (rest tokens)}))) (defn apply-fn-parser [parser tokens] - (let [rule (:rule parser) name (:name parser)] - (rule tokens))) + (let [rule (:rule parser) name (:name parser) result (rule tokens)] + (if (pass? result) (println "Matched " (:name parser))) + result)) (defn apply-parser [parser tokens] + (println "Applying parser " (? (:name parser) parser)) (cond (keyword? parser) (apply-kw-parser parser tokens) (:rule parser) (apply-fn-parser parser tokens) @@ -139,7 +142,11 @@ :group (recur (vec (concat results (:data result))) (remaining result)) :quiet (recur results (remaining result)) :err (update result :trace #(conj % name)) - {:status :group :type name :data results :token (first tokens) :remaining ts}))))})) + :none {:status :group + :type name + :data results + :token (first tokens) + :remaining ts}))))})) (defn one+ ([parser] (one+ (pname parser) parser)) @@ -196,6 +203,16 @@ (assoc result :status :ok) result)))})) +(defn weak + ([parser] (weak (pname parser) parser)) + ([name parser] + {:name (kw+str name "-weak") + :rule (fn weak-fn [tokens] + (let [result (apply-parser parser tokens)] + (if (= :err (:status result)) + (assoc result :status :none) + result)))})) + (defn err-msg [{token :token trace :trace}] (println "Unexpected token " (:type token) " on line " (:line token)) (println "Expected token " (first trace))) From 4ea7a3a23dfe4ce867e26dceb0f9dbf878770d47 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Fri, 19 May 2023 18:55:14 -0400 Subject: [PATCH 15/43] Keep grinding; problems now with order/repeats --- src/ludus/grammar.clj | 287 +++++++++++++++++---------------------- src/ludus/parser_new.clj | 124 +++++++++-------- src/ludus/scanner.clj | 60 +++----- 3 files changed, 212 insertions(+), 259 deletions(-) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 23dc653..3dfc9cc 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -4,259 +4,218 @@ (declare expression pattern) -(def separator (choice :separator [:comma :newline])) +(def separator (choice :separator [:comma :newline :break])) -(def terminator (choice :terminator [:newline :semicolon])) +(def separators (quiet (one+ separator))) -(defn entries [name sep parser] - (zero+ (weak (order name [(quiet (one+ sep)) parser])))) +(def terminator (choice :terminator [:newline :semicolon :break])) + +(def terminators (quiet (one+ terminator))) (def nls? (quiet (zero+ :nls :newline))) -(def splat (group (order :splat [(quiet :splat) :word]))) +(def splat (group (order-1 :splat [(quiet :splat) :word]))) -(def splattern (group (order :splat [(quiet :splat) (flat (choice :splatted [:word :ignored :placeholder]))]))) +(def splattern (group (order-1 :splat [(quiet :splat) (flat (choice :splatted [:word :ignored :placeholder]))]))) (def literal (flat (choice :literal [:nil :true :false :number :string]))) -(def tuple-pattern-term (choice :tuple-pattern-term [pattern splattern])) +(def tuple-pattern-term (flat (choice :tuple-pattern-term [pattern splattern]))) -(def tuple-pattern-entries (entries :tuple-pattern-enries separator pattern)) +(def tuple-pattern-entry (order-1 :tuple-pattern-entry [tuple-pattern-term (quiet (one+ separator))])) -(def tuple-pattern (group (order :tuple-pattern +(def tuple-pattern (group (order-1 :tuple-pattern [(quiet :lparen) (quiet (zero+ separator)) - (maybe pattern) - tuple-pattern-entries - (quiet (zero+ separator)) + (zero+ tuple-pattern-entry) (quiet :rparen)]))) -(def list-pattern (group (order :list-pattern +(def list-pattern (group (order-1 :list-pattern [(quiet :lbracket) (quiet (zero+ separator)) - (maybe pattern) - tuple-pattern-entries - (quiet (zero+ separator)) + (zero+ tuple-pattern-entry) (quiet :rbracket)]))) -(def pair-pattern (order :pair-pattern [:keyword pattern])) +(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-entries (entries :dict-pattern-entries separator dict-pattern-term)) +(def dict-pattern-entry (order-1 :dict-pattern-entry [dict-pattern-term (quiet (one+ separator))])) -(def dict-pattern (group (order :dict-pattern +(def dict-pattern (group (order-1 :dict-pattern [(quiet :startdict) (quiet (zero+ separator)) - (maybe dict-pattern-term) - dict-pattern-entries - (quiet (zero+ separator)) + (zero+ dict-pattern-entry) (quiet :rbrace) ]))) -(def struct-pattern (group (order :struct-pattern +(def struct-pattern (group (order-1 :struct-pattern [(quiet :startstruct) (quiet (zero+ separator)) - (maybe dict-pattern-term) - dict-pattern-entries - (quiet (zero+ separator)) + (zero+ dict-pattern-entry) (quiet :rbrace) ]))) -(def constraint (order :constraint [:when expression])) +(def constraint (order-0 :constraint [(quiet :when) expression])) (def pattern (choice :pattern [literal :ignored :placeholder :word :keyword tuple-pattern dict-pattern struct-pattern list-pattern])) -(def match-clause (group (order :match-clause +(def match-clause (group (order-0 :match-clause [pattern (maybe constraint) (quiet :rarrow) expression]))) -(def match-entries (entries :match-entries terminator match-clause)) +(def match-entry (order-0 :match-entry [match-clause (quiet (one+ terminator))])) -(def match (group (order :match +(def match (group (order-1 :match [(quiet :match) expression nls? - (quiet :with) (quiet :lbrace) nls? - match-clause - match-entries - nls? + (quiet :with) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ match-entry) (quiet :rbrace) ]))) -(def iff (order :if [(quiet :if) - nls? - expression - nls? - (quiet :then) - expression - nls? - (quiet :else) - expression])) +(def iff (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 (order :cond-clause [cond-lhs (quiet :rarrow) expression]))) +(def cond-clause (group (order-0 :cond-clause [cond-lhs (quiet :rarrow) expression]))) -(def cond-entries (entries :cond-entries terminator cond-clause)) +(def cond-entry (order-0 :cond-entry [cond-clause (quiet (one+ terminator))])) -(def condd (order :cond [(quiet :cond) (quiet :lbrace) - (quiet (zero+ terminator)) - cond-clause - cond-entries - (quiet (zero+ terminator)) - (quiet :rbrace)])) +(def condd (order-1 :cond [(quiet :cond) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ cond-entry) + (quiet :rbrace)])) -(def lett (group (order :let [(quiet :let) - pattern - (quiet :equals) - nls? - expression]))) +(def lett (group (order-1 :let [(quiet :let) + pattern + (quiet :equals) + nls? + expression]))) -(def tuple-entry (weak (order :tuple-entry [(quiet (one+ separator)) expression]))) - -(def tuple-entries (entries :tuple-entries separator expression)) - -(def tuple (group (order :tuple - [(quiet :lparen) - (quiet (zero+ separator)) - (maybe expression) - tuple-entries - (quiet (zero+ separator)) - (quiet :rparen)]))) +(def tuple-entry (order-1 :tuple-entry [expression separators])) + +(def tuple (group (order-1 :tuple [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ tuple-entry) + (quiet :rparen)]))) (def list-term (flat (choice :list-term [splat expression]))) -(def list-entry (weak (order :list-entry [(quiet (one+ separator)) list-term]))) +(def list-entry (order-1 :list-entry [list-term separators])) -(def list-entries (entries :list-entries separator list-term)) - -(def listt (group (order :list +(def listt (group (order-1 :list [(quiet :lbracket) (quiet (zero+ separator)) - (maybe list-term) - list-entries - (quiet (zero+ separator)) + (zero+ list-entry) (quiet :rbracket)]))) -(def sett (group (order :set [ - (quiet :startset) - (quiet (zero+ separator)) - (maybe list-term) - list-entries - (quiet (zero+ separator)) - (quiet :rbrace)]))) +(def sett (group (order-1 :set [ + (quiet :startset) + (quiet (zero+ separator)) + (zero+ list-entry) + (quiet :rbrace)]))) -(def pair (group (order :pair [:keyword expression]))) +(def pair (group (order-0 :pair [:keyword expression]))) (def struct-term (flat (choice :struct-term [:word pair]))) -(def struct-entry (weak (order :struc-entry [(quiet (one+ separator)) struct-term]))) +(def struct-entry (order-1 :struct-entry [struct-term separators])) -(def struct-entries (entries :struct-entries separator struct-term)) - -(def structt (group (order :struct +(def structt (group (order-1 :struct [(quiet :startstruct) (quiet (zero+ separator)) - (maybe struct-term) - struct-entries - (quiet (zero+ separator)) + (zero+ struct-entry) (quiet :rbrace)]))) (def dict-term (flat (choice :dict-term [:word pair splat]))) -(def dict-entry (weak (order :dict-entry [(quiet (one+ separator)) dict-term]))) +(def dict-entry (order-1 :dict-entry [dict-term separators])) -(def dict-entries (entries :dict-entries separator dict-term)) - -(def dict (group (order :dict +(def dict (group (order-1 :dict [(quiet :startdict) (quiet (zero+ separator)) - (maybe dict-term) - dict-entries - (quiet (zero+ separator)) + (zero+ dict-entry) (quiet :rbrace)]))) (def arg-expr (flat (choice :arg-expr [:placeholder expression]))) -(def arg-entry (weak (order :arg-entry [(quiet (one+ separator)) arg-expr]))) +(def arg-entry (order-1 :arg-entry [arg-expr separators])) -(def arg-entries (entries :arg-entries separator arg-expr)) - -(def arg-tuple (order :arg-tuple +(def arg-tuple (order-1 :arg-tuple [(quiet :lparen) (quiet (zero+ separator)) - (maybe arg-expr) - arg-entries - (quiet (zero+ separator)) + (zero+ arg-entry) (quiet :rparen)])) (def synth-root (choice :synth-root [:keyword :word :recur])) (def synth-term (choice :synth-term [arg-tuple :keyword])) -(def synthetic (order :synthetic [synth-root (zero+ synth-term)])) +(def synthetic (order-1 :synthetic [synth-root (zero+ synth-term)])) -(def fn-clause (group (order :fn-clause [tuple-pattern (maybe constraint) (quiet :rarrow) expression]))) +(def fn-clause (group (order-0 :fn-clause [tuple-pattern (maybe constraint) (quiet :rarrow) expression]))) -(def fn-entry (weak (order :fn-entry [(quiet (one+ terminator)) fn-clause]))) +(def fn-entry (order-1 :fn-entry [fn-clause terminators])) -(def fn-entries (entries :fn-entries terminator fn-clause)) +(def compound (group (order-1 :compound [(quiet :lbrace) + nls? + (maybe :string) + (quiet (zero+ terminator)) + (one+ fn-entry) + (quiet :rbrace) + ]))) -(def compound (group (order :compound [(quiet :lbrace) - nls? - (maybe :string) - nls? - fn-clause - fn-entries - nls? - (quiet :rbrace) - ]))) +(def clauses (flat (choice :clauses [fn-clause compound]))) -(def clauses (flat (choice :clauses [compound fn-clause]))) - -(def named (group (order :named [:word clauses]))) +(def named (group (order-1 :named [:word clauses]))) (def body (flat (choice :body [fn-clause named]))) -(def fnn (group (order :fn [(quiet :fn) body]))) +(def fnn (group (order-1 :fn [(quiet :fn) body]))) -(def block-lines (entries :block-lines terminator expression)) +(def block-line (order-1 :block-line [expression terminators])) -(def block (group (order :block [(quiet :lbrace) - nls? - expression - block-lines - nls? (quiet :rbrace)]))) +(def block (group (order-1 :block [(quiet :lbrace) + (quiet (zero+ terminator)) + (zero+ block-line) + (quiet :rbrace)]))) -(def pipeline (order :pipeline [nls? :pipeline])) +(def pipeline (order-0 :pipeline [nls? :pipeline])) -(def do-entry (weak (order :do-entry [pipeline expression]))) +(def do-entry (order-0 :do-entry [pipeline expression])) -(def doo (group (order :do [ - (quiet :do) - expression - (one+ do-entry) - ]))) +(def doo (group (order-1 :do [(quiet :do) + expression + ;; should this be zero+? + (one+ do-entry) + ]))) -(def reff (group (order :ref [(quiet :ref) :word (quiet :equals) expression]))) +(def reff (group (order-1 :ref [(quiet :ref) :word (quiet :equals) expression]))) -(def spawn (group (order :spawn [(quiet :spawn) expression]))) +(def spawn (group (order-1 :spawn [(quiet :spawn) expression]))) -(def receive (group (order :receive - [(quiet :receive) (quiet :lbrace) nls? - match-clause - match-entries - nls? +(def receive (group (order-1 :receive + [(quiet :receive) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ match-entry) (quiet :rbrace) ]))) -(def compound-loop (group (order :compound-loop +(def compound-loop (group (order-0 :compound-loop [(quiet :lbrace) - nls? - fn-clause - fn-entries - nls? + (quiet (zero+ terminator)) + (one+ fn-entry) (quiet :rbrace)]))) -(def loopp (group (order :loop +(def loopp (group (order-1 :loop [(quiet :loop) tuple (quiet :with) (flat (choice :loop-body [fn-clause compound-loop]))]))) @@ -279,28 +238,24 @@ tuple literal]))) -(def test (group (order :test [(quiet :test) :string expression]))) +(def testt (group (order-1 :test [(quiet :test) :string expression]))) -(def importt (group (order :import [(quiet :import) :string (quiet :as) :word]))) +(def importt (group (order-1 :import [(quiet :import) :string (quiet :as) :word]))) -(def nss (group (order :nss [(quiet :ns) - :word - (quiet :lbrace) - (quiet (zero+ separator)) - (maybe struct-term) - (zero+ struct-entry) - (quiet (zero+ separator)) - (quiet :rbrace)]))) +(def nss (group (order-1 :nss [(quiet :ns) + :word + (quiet :lbrace) + (quiet (zero+ separator)) + (zero+ struct-entry) + (quiet :rbrace)]))) -(def toplevel (flat (choice :toplevel [importt nss expression test]))) +(def toplevel (flat (choice :toplevel [importt nss expression testt]))) -(def script-lines (entries :script-lines terminator toplevel)) +(def script-line (order-0 :script-line [toplevel terminators])) -(def script (order :script [nls? - toplevel - script-lines - nls? - (quiet :eof)])) +(def script (order-0 :script [nls? + (one+ script-line) + (quiet :eof)])) ;;;;;;;;;;;;;;;; REPL CRUFT @@ -309,16 +264,16 @@ ;; --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 - "receive { _ -> 1; () -> 2 } - " + "{1; 2; 3; (1, _)}" ))) -(def result (apply-parser script eg)) +(def result (apply-parser block eg)) (defn report [node] diff --git a/src/ludus/parser_new.clj b/src/ludus/parser_new.clj index 8cef82b..71c9db8 100644 --- a/src/ludus/parser_new.clj +++ b/src/ludus/parser_new.clj @@ -44,10 +44,13 @@ (defn apply-parser [parser tokens] (println "Applying parser " (? (:name parser) parser)) - (cond - (keyword? parser) (apply-kw-parser parser tokens) - (:rule parser) (apply-fn-parser parser tokens) - :else (throw (Exception. "`apply-parser` requires a parser")))) + (let [result (cond + (keyword? parser) (apply-kw-parser parser tokens) + (:rule parser) (apply-fn-parser parser tokens) + :else (throw (Exception. "`apply-parser` requires a parser")))] + (println "Parser result " (? (:name parser) parser) (:status result)) + result + )) (defn choice [name parsers] {:name name @@ -67,8 +70,9 @@ {:status :none :token (first tokens) :trace [name] :remaining rem-ts} :else (recur rem-ps)))))}) - -(defn order [name parsers] +;; 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) @@ -121,6 +125,49 @@ (:err :none) (assoc (update result :trace #(conj % name)) :status :err))))))))}) +(defn order-0 [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) + (assoc (update result :trace #(conj % name)) :status :err)) + + ;; 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) + (assoc (update result :trace #(conj % name)) :status :err)))))))}) + (defn quiet [parser] {:name (kw+str (? (:name parser) parser) "-quiet") :rule (fn quiet-fn [tokens] @@ -158,11 +205,23 @@ (case (:status first-result) (:ok :group) (let [rest-result (apply-parser rest-parser (remaining first-result))] - {:status :group - :type name - :data (vec (concat [first-result] (data rest-result))) - :token (first tokens) - :remaining (remaining rest-result)}) + (case (:status rest-result) + + (:ok :group :quiet) + {:status :group + :type name + :data (vec (concat [first-result] (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 #(conj % name))) + + ) :quiet (let [rest-result (apply-parser rest-parser (remaining first-result))] @@ -203,49 +262,6 @@ (assoc result :status :ok) result)))})) -(defn weak - ([parser] (weak (pname parser) parser)) - ([name parser] - {:name (kw+str name "-weak") - :rule (fn weak-fn [tokens] - (let [result (apply-parser parser tokens)] - (if (= :err (:status result)) - (assoc result :status :none) - result)))})) - (defn err-msg [{token :token trace :trace}] (println "Unexpected token " (:type token) " on line " (:line token)) (println "Expected token " (first trace))) - -(comment - " - If I'm not mistaken, the Ludus grammer requires *no* lookahead, the first token in an expression tells you what kind of expression it is: - - Rather, there is one ambiguity: synthetic expressions can start with words or keywords. - A bare word can be assimilated to synthetic expressions. Interestingly, so can synthetic. - - The parsing strategy is the same: consume as many things until you can't get anymore. - - The fact that a bare keyword is evaluated like a literal doesn't matter. - - So: - literal -> literal - keyword -> synthetic - word -> synthetic - ( -> tuple - [ -> list - #{ -> dict - @{ -> struct - ns -> ns - let -> let - do -> pipeline - - etc. - - Because there's now NO lookahead, we can easily distinguish between orderings that don't match at all, and ones which match on the first token. - - Because of that, we can also distinguish between no-match and errors - - ") - - diff --git a/src/ludus/scanner.clj b/src/ludus/scanner.clj index dc80ca9..a4c5ea8 100644 --- a/src/ludus/scanner.clj +++ b/src/ludus/scanner.clj @@ -36,7 +36,7 @@ ;; type system ;; "data" :data ;; we are going to tear out datatypes for now: see if dynamism works for us ;; others - "repeat" :repeat ;; syntax sugar over "loop": still unclear what this syntax could be + ;;"repeat" :repeat ;; syntax sugar over "loop": still unclear what this syntax could be "test" :test "when" :when ;; "module" :module ;; not necessary if we don't have datatypes @@ -113,11 +113,7 @@ (defn- whitespace? [c] (or (= c \space) (= c \tab))) -;; TODO: update token terminators: -;; remove: \| -;; add: \> -;; research others -(def terminators #{\: \; \newline \{ \} \( \) \[ \] \$ \# \- \= \& \, \| nil \\}) +(def terminators #{\: \; \newline \{ \} \( \) \[ \] \$ \# \- \= \& \, \> nil \\}) (defn- terminates? [c] (or (whitespace? c) (contains? terminators c))) @@ -176,24 +172,29 @@ (digit? curr) (recur (advance scanner) (str num curr) float?) :else (add-error scanner (str "Unexpected " curr " after number " num ".")))))) -;; TODO: add string interpolation -;; This still has to be devised +;; TODO: activate string interpolation (defn- add-string [scanner] (loop [scanner scanner - string ""] + string "" + interpolate? false] (let [char (current-char scanner)] (case char - \newline (add-error scanner "Unterminated string.") - \" (add-token (advance scanner) :string string) + \{ (recur (update (advance scanner)) (str string char) true) + ; allow multiline strings + \newline (recur (update (advance scanner) :line inc) (str string char) interpolate?) + \" (if interpolate? + ;(add-token (advance scanner) :interpolated string) + (add-token (advance scanner) :string string) + (add-token (advance scanner) :string string)) \\ (let [next (next-char scanner) scanner (if (= next \newline) (update scanner :line inc) scanner)] - (recur (advance (advance scanner)) (str string next))) + (recur (advance (advance scanner)) (str string next) interpolate?)) (if (at-end? scanner) (add-error scanner "Unterminated string.") - (recur (advance scanner) (str string char))))))) + (recur (advance scanner) (str string char) interpolate?)))))) (defn- add-word [char scanner] @@ -242,11 +243,13 @@ (case char ;; one-character tokens \( (add-token scanner :lparen) - \) (add-token scanner :rparen) + ;; :break is a special zero-char token before closing braces + ;; it makes parsing much simpler + \) (add-token (add-token scanner :break) :rparen) \{ (add-token scanner :lbrace) - \} (add-token scanner :rbrace) + \} (add-token (add-token scanner :break) :rbrace) \[ (add-token scanner :lbracket) - \] (add-token scanner :rbracket) + \] (add-token (add-token scanner :break) :rbracket) \; (add-token scanner :semicolon) \, (add-token scanner :comma) \newline (add-token (update scanner :line inc) :newline) @@ -261,23 +264,6 @@ (digit? next) (add-number char scanner) :else (add-error scanner (str "Expected -> or negative number after `-`. Got `" char next "`"))) - ;; at current we're not using this - ;; <- - ;;\< (if (= next \-) - ;; (add-token (advance scanner) :larrow) - ;; (add-error scanner (str "Expected <-. Got " char next))) - - ;; |> - ;; Consider => , with =>> for bind - ; \| (if (= next \>) - ; (add-token (advance scanner) :pipeline) - ; (add-error scanner (str "Expected |>. Got " char next))) - - ;; possible additional operator: bind/result - ;; possible additional operator: bind/some - ;; oh god, monads - ;; additional arrow possibilities: >> ||> ~> => !> - ;; dict #{ \# (if (= next \{) (add-token (advance scanner) :startdict) @@ -302,8 +288,6 @@ ;; comments ;; & starts an inline comment - ;; TODO: include comments in scanned file - ;; TODO, maybe: add doc comments: &&& (or perhaps a docstring in an fn?) \& (add-comment char scanner) ;; keywords @@ -324,7 +308,7 @@ (cond (whitespace? char) scanner ;; for now just skip whitespace characters (digit? char) (add-number char scanner) - (upper? char) (add-data char scanner) + (upper? char) (add-word char scanner) ;; no datatypes for now (lower? char) (add-word char scanner) :else (add-error scanner (str "Unexpected character: " char)))))) @@ -334,10 +318,8 @@ (defn scan [source] (loop [scanner (new-scanner source)] (if (at-end? scanner) - (let [scanner (add-token scanner :eof)] + (let [scanner (add-token (add-token scanner :break) :eof)] {:tokens (:tokens scanner) :errors (:errors scanner)}) (recur (-> scanner (scan-token) (next-token)))))) -(scan "2 :three true nil") - From 4fd593752b398b596ae50e0c2524dfd8267daba7 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sat, 20 May 2023 14:18:30 -0400 Subject: [PATCH 16/43] 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))] From 0fe85cf2edfa5b496eefadc6aaa3473e3dc5e87c Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sat, 20 May 2023 14:20:23 -0400 Subject: [PATCH 17/43] Remove repl cruft --- src/ludus/grammar.clj | 43 +------------------------------------------ 1 file changed, 1 insertion(+), 42 deletions(-) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 2a10612..eafaa33 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -255,45 +255,4 @@ (def script (order-0 :script [nls? (one+ script-line) - (quiet :eof)])) - - -;;;;;;;;;;;;;;;; REPL CRUFT - -;;TODO: fix forward declaration errors - - -(def eg (:tokens (scan/scan - " - test \"foo\" bar - " - ))) - - - -(def result (apply-parser script eg)) - - -(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 tap [x] (println "\n\n\n\n******NEW PARSE\n\n:::=> " x "\n\n") x) - -(def my-data (-> result - clean - tap - )) - -my-data \ No newline at end of file + (quiet :eof)])) \ No newline at end of file From ae8f72d3b4152bd37727e8b372674c19e4cd02f2 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sat, 20 May 2023 14:25:13 -0400 Subject: [PATCH 18/43] Remove debug printlns --- src/ludus/compile.clj | 5 +++++ src/ludus/parser_new.clj | 8 ++++---- 2 files changed, 9 insertions(+), 4 deletions(-) create mode 100644 src/ludus/compile.clj diff --git a/src/ludus/compile.clj b/src/ludus/compile.clj new file mode 100644 index 0000000..e3f0423 --- /dev/null +++ b/src/ludus/compile.clj @@ -0,0 +1,5 @@ +(ns ludus.compile + (:require + [ludus.grammar :as g] + [ludus.parser-new :as p] + [ludus.scanner :as s])) \ No newline at end of file diff --git a/src/ludus/parser_new.clj b/src/ludus/parser_new.clj index c36aab6..6dfc8b5 100644 --- a/src/ludus/parser_new.clj +++ b/src/ludus/parser_new.clj @@ -28,7 +28,7 @@ (defn apply-kw-parser [kw tokens] (let [token (first tokens)] - (if (= kw (:type token)) (println "Matched " kw)) + ;(if (= kw (:type token)) (println "Matched " kw)) (if (= kw (:type token)) {:status :ok :type kw @@ -39,16 +39,16 @@ (defn apply-fn-parser [parser tokens] (let [rule (:rule parser) name (:name parser) result (rule tokens)] - (if (pass? result) (println "Matched " (:name parser))) + ;(if (pass? result) (println "Matched " (:name parser))) result)) (defn apply-parser [parser tokens] - (println "Applying parser " (? (:name parser) parser)) + ;(println "Applying parser " (? (:name parser) parser)) (let [result (cond (keyword? parser) (apply-kw-parser parser tokens) (:rule parser) (apply-fn-parser parser tokens) :else (throw (Exception. "`apply-parser` requires a parser")))] - (println "Parser result " (? (:name parser) parser) (:status result)) + ;(println "Parser result " (? (:name parser) parser) (:status result)) result )) From e02e972d27c95e199cffc723ace7af5384e51df7 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sat, 20 May 2023 14:25:33 -0400 Subject: [PATCH 19/43] Start work on a compiler --- src/ludus/compile.clj | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/ludus/compile.clj b/src/ludus/compile.clj index e3f0423..bcfd8df 100644 --- a/src/ludus/compile.clj +++ b/src/ludus/compile.clj @@ -2,4 +2,12 @@ (:require [ludus.grammar :as g] [ludus.parser-new :as p] - [ludus.scanner :as s])) \ No newline at end of file + [ludus.scanner :as s])) + +(def source + "1" + ) + +(def result (->> source s/scan :tokens (p/apply-parser g/script))) + +(println result) \ No newline at end of file From 8516f0e0532fb3b6c063dfd723f69318f0457741 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sun, 21 May 2023 16:43:26 -0400 Subject: [PATCH 20/43] Start work on the interpreter --- src/ludus/compile.clj | 23 ++- src/ludus/grammar.clj | 90 +++++++---- src/ludus/interpreter.clj | 295 ++++++++++++++++++++++------------ src/ludus/interpreter_new.clj | 41 +++++ src/ludus/parser_new.clj | 2 +- src/ludus/prelude.clj | 9 +- 6 files changed, 322 insertions(+), 138 deletions(-) create mode 100644 src/ludus/interpreter_new.clj diff --git a/src/ludus/compile.clj b/src/ludus/compile.clj index bcfd8df..b732707 100644 --- a/src/ludus/compile.clj +++ b/src/ludus/compile.clj @@ -10,4 +10,25 @@ (def result (->> source s/scan :tokens (p/apply-parser g/script))) -(println result) \ No newline at end of file +(println result) + +(comment " + What sorts of compiling and validation do we want to do? Be specific. + + - check used names are bound (validation) + - check bound names are available (validation) + - check `recur` is only ever in `loop` and in `fn` bodies (validation) + - separate function arities into different functions (optimization) + - desugar partially applied functions (simplification) + - desugar keyword entry shorthand (simplification) + - flag tail calls for optimization (optimization) + - direct tail calls + - through different expressions + - block + - if + - cond + - match + - let + - check ns access + + ") \ No newline at end of file diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index eafaa33..79a35dd 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -58,9 +58,11 @@ (def constraint (order-0 :constraint [(quiet :when) expression])) -(def pattern (choice :pattern [literal :ignored :placeholder :word :keyword tuple-pattern dict-pattern struct-pattern list-pattern])) +(def typed (group (weak-order :typed [:word (quiet :as) :keyword]))) -(def match-clause (group (order-0 :match-clause +(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])) @@ -73,26 +75,26 @@ (quiet :rbrace) ]))) -(def iff (order-1 :if [(quiet :if) - nls? - expression - nls? - (quiet :then) - expression - nls? - (quiet :else) - expression])) +(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 (order-0 :cond-clause [cond-lhs (quiet :rarrow) expression]))) +(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 (order-1 :cond [(quiet :cond) (quiet :lbrace) - (quiet (zero+ terminator)) - (one+ cond-entry) - (quiet :rbrace)])) +(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 @@ -147,19 +149,19 @@ (def arg-expr (flat (choice :arg-expr [:placeholder expression]))) -(def arg-entry (order-1 :arg-entry [arg-expr separators])) +(def arg-entry (weak-order :arg-entry [arg-expr separators])) -(def arg-tuple (order-1 :arg-tuple - [(quiet :lparen) - (quiet (zero+ separator)) - (zero+ arg-entry) - (quiet :rparen)])) +(def args (group (order-1 :args + [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ arg-entry) + (quiet :rparen)]))) -(def synth-root (choice :synth-root [:keyword :word :recur])) +(def synth-root (flat (choice :synth-root [:keyword :word :recur]))) -(def synth-term (choice :synth-term [arg-tuple :keyword])) +(def synth-term (flat (choice :synth-term [args :keyword]))) -(def synthetic (order-1 :synthetic [synth-root (zero+ synth-term)])) +(def synthetic (group (order-1 :synthetic [synth-root (zero+ synth-term)]))) (def fn-clause (group (order-0 :fn-clause [tuple-pattern (maybe constraint) (quiet :rarrow) expression]))) @@ -185,7 +187,7 @@ (def block (group (order-1 :block [(quiet :lbrace) (quiet (zero+ terminator)) - (zero+ block-line) + (one+ block-line) (quiet :rbrace)]))) (def pipeline (order-0 :pipeline [nls? :pipeline])) @@ -255,4 +257,38 @@ (def script (order-0 :script [nls? (one+ script-line) - (quiet :eof)])) \ No newline at end of file + (quiet :eof)])) + + +;;; REPL + +(comment (def source + "if 1 then 2 else 3" + ) + + (def result (apply-parser script source)) + + + (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 tap [x] (println "\n\n\n\n******NEW RUN\n\n:::=> " x "\n\n") x) + + (def my-data (-> result + clean + tap + )) + + (println my-data)) \ No newline at end of file diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index 181e52a..6ac3138 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -1,6 +1,8 @@ (ns ludus.interpreter (:require [ludus.parser :as parser] + [ludus.parser-new :as p] + [ludus.grammar :as g] [ludus.scanner :as scanner] [ludus.ast :as ast] [ludus.prelude :as prelude] @@ -27,9 +29,9 @@ ::not-found)))) (defn- resolve-word [word ctx] - (let [value (ludus-resolve (:word word) ctx)] + (let [value (ludus-resolve (-> word :data first) ctx)] (if (= ::not-found value) - (throw (ex-info (str "Unbound name: " (:word word)) {:ast word})) + (throw (ex-info (str "Unbound name: " (-> word :data first)) {:ast word})) value))) (declare interpret-ast match interpret interpret-file) @@ -95,16 +97,16 @@ :else (let [members (:members pattern) - ctx-diff (volatile! @ctx-vol)] - (loop [i (dec (count members))] - (if (> 0 i) - {:success true :ctx @ctx-diff} - (let [match? (match (nth members i) (nth value i) ctx-diff)] - (if (:success match?) - (do - (vswap! ctx-diff #(merge % (:ctx match?))) - (recur (dec i))) - {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))}))))))) + ctx-diff (volatile! @ctx-vol)] + (loop [i (dec (count members))] + (if (> 0 i) + {:success true :ctx @ctx-diff} + (let [match? (match (nth members i) (nth value i) ctx-diff)] + (if (:success match?) + (do + (vswap! ctx-diff #(merge % (:ctx match?))) + (recur (dec i))) + {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))}))))))) (defn- match-dict [pattern value ctx-vol] (cond @@ -131,7 +133,7 @@ (recur (dec i))) {:success false :reason (str "Could not match " pattern " with " value " at key " kw " because " (:reason match?))})) {:success false - :reason (str "Could not match " pattern " with " value " at key " kw " because there is no value at " kw)}))))))) + :reason (str "Could not match " pattern " with " value " at key " kw " because there is no value at " kw)}))))))) (defn- match-struct [pattern value ctx-vol] (cond @@ -158,42 +160,86 @@ {:success false :reason (str "Could not match " pattern " with " value " at key " kw " because " (:reason match?))})) {:success false :reason (str "Could not match " pattern " with " value " at key " kw ", because there is no value at " kw)}))))))) +(defn- get-type [value] + (let [t (type value)] + (cond + (nil? value) :nil + + (= clojure.lang.Keyword t) :keyword + + (= java.lang.Long t) :number + + (= java.lang.Double t) :number + + (= java.lang.String t) :string + + (= java.lang.Boolean t) :boolean + + (= clojure.lang.PersistentHashSet t) :set + + ;; tuples and lists + (= clojure.lang.PersistentVector t) + (if (= ::data/tuple (first value)) :tuple :list) + + ;; structs dicts namespaces refs + (= clojure.lang.PersistentArrayMap t) + (cond + (::data/dict value) :dict + (::data/struct value) :struct + :else :none + ) + + ))) + +(get-type [::data/tuple]) + +(defn- match-typed [pattern value ctx] + (let [data (:data pattern) + name (-> data first :data) + type (-> data second :data)] + (cond + (contains? ctx name) {:success false :reason (str "Name " name "is already bound") :code :name-error} + (not (= type (get-type value))) {:success false :reason (str "Could not match " pattern " with " value ", because types do not match")} + :else {:success true :ctx {name value}}))) + (defn- match [pattern value ctx-vol] (let [ctx @ctx-vol] - (case (::ast/type pattern) - ::ast/placeholder {:success true :ctx {}} + (case (:type pattern) + (:placeholder :ignored) + {:success true :ctx {}} - ::ast/atom - (let [match-value (:value pattern)] + (:number :nil :true :false :string :keyword) + (let [match-value (-> pattern :data first)] (if (= match-value value) {:success true :ctx {}} {:success false :reason (str "No match: Could not match " match-value " with " value)})) - ::ast/word - (let [word (:word pattern)] + :word + (let [word (-> pattern :data first)] (if (contains? ctx word) {:success false :reason (str "Name " word " is already bound") :code :name-error} {:success true :ctx {word value}})) - ::ast/tuple (match-tuple pattern value ctx-vol) + :typed (match-typed pattern value ctx) - ::ast/list (match-list pattern value ctx-vol) + :tuple (match-tuple pattern value ctx-vol) - ::ast/dict (match-dict pattern value ctx-vol) + :list (match-list pattern value ctx-vol) - ::ast/struct (match-struct pattern value ctx-vol) + :dict (match-dict pattern value ctx-vol) + + :struct (match-struct pattern value ctx-vol) (throw (ex-info "Unknown pattern on line " {:pattern pattern}))))) (defn- update-ctx [ctx new-ctx] (merge ctx new-ctx)) -;; TODO: get "if let" pattern working -;; TODO: get typed exceptions to distinguish panics (defn- interpret-let [ast ctx] - (let [pattern (:pattern ast) - expr (:expr ast) + (let [data (:data ast) + pattern (first data) + expr (second data) value (interpret-ast expr ctx) match (match pattern value ctx) success (:success match)] @@ -203,59 +249,76 @@ value)) (defn- interpret-if-let [ast ctx] - (let [if-ast (:if ast) - then-expr (:then ast) - else-expr (:else ast) - if-pattern (:pattern if-ast) - if-expr (:expr if-ast) - if-value (interpret-ast if-expr ctx) - if-match (match if-pattern if-value ctx) - success (:success if-match)] - (if success - (interpret-ast then-expr (volatile! (merge (:ctx if-match) {:parent ctx}))) - (if (:code if-match) - (throw (ex-info (:reason if-match) {:ast if-ast})) - (interpret-ast else-expr ctx))))) + (let [data (:data ast) + if-ast (first data) + then-expr (second data) + else-expr (nth data 2) + if-data (:data if-ast) + let-pattern (first if-data) + let-expr (second if-data) + let-value (interpret-ast let-expr ctx) + if-match (match let-pattern let-value ctx) + success (:success if-match)] + (if success + (interpret-ast then-expr (volatile! (merge (:ctx if-match) {:parent ctx}))) + (if (:code if-match) + (throw (ex-info (:reason if-match) {:ast if-ast})) + (interpret-ast else-expr ctx))))) (defn- interpret-if [ast ctx] - (let [if-expr (:if ast) - then-expr (:then ast) - else-expr (:else ast)] - (if (= (::ast/type if-expr) ::ast/let) - (interpret-if-let ast ctx) - (if (interpret-ast if-expr ctx) - (interpret-ast then-expr ctx) - (interpret-ast else-expr ctx))))) + (let [data (:data ast) + if-expr (first data) + then-expr (second data) + else-expr (nth data 2)] + (if (= (:type if-expr) :let) + (interpret-if-let ast ctx) + (if (interpret-ast if-expr ctx) + (interpret-ast then-expr ctx) + (interpret-ast else-expr ctx))))) (defn- interpret-match [ast ctx] - (let [match-expr (:expr ast) - expr (interpret-ast match-expr ctx) - clauses (:clauses ast)] + (let [data (:data ast) + match-expr (first data) + value (interpret-ast match-expr ctx) + clauses (rest data)] (loop [clause (first clauses) clauses (rest clauses)] (if clause - (let [pattern (:pattern clause) - body (:body clause) + (let [clause-data (:data clause) + pattern (first clause-data) + constraint (if (= 3 (count clause-data)) + (second clause-data) + nil) + body (peek clause-data) new-ctx (volatile! {::parent ctx}) - match? (match pattern expr new-ctx) + match? (match pattern value new-ctx) success (:success match?) clause-ctx (:ctx match?)] - (if success + (if success (do (vswap! new-ctx #(merge % clause-ctx)) - (interpret-ast body new-ctx)) + (if constraint + (if (interpret-ast constraint new-ctx) + (interpret-ast body new-ctx) + (recur (first clauses) (rest clauses))) + (interpret-ast body new-ctx))) (recur (first clauses) (rest clauses)))) (throw (ex-info "Match Error: No match found" {:ast ast})))))) (defn- interpret-cond [ast ctx] - (let [clauses (:clauses ast)] + (let [clauses (:data ast)] (loop [clause (first clauses) clauses (rest clauses)] (if (not clause) (throw (ex-info "Cond Error: No match found" {:ast ast})) - (let [test-expr (:test clause) - body (:body clause) - truthy? (boolean (interpret-ast test-expr ctx))] + (let [data (:data clause) + test-expr (first data) + test-type (:type test-expr) + body (second data) + truthy? (or + (= :placeholder test-type) + (= :else test-type) + (interpret-ast test-expr ctx))] (if truthy? (interpret-ast body ctx) (recur (first clauses) (rest clauses)))))))) @@ -322,28 +385,48 @@ :else (throw (ex-info "I don't know how to call that" {:ast lfn})))) +(defn- validate-args [args] + (>= 1 (count (filter #(= :placeholder (:type %)) args)))) + +(defn- partial? [args] + (some #(= :placeholder (:type %)) args)) + +(defn- interpret-args [ast ctx] + (let [members (:data ast)] + (if (partial? args) + (if (validate-args) + () ; do the thing + (throw (ex-info "Partially applied functions may only take a single argument"))) + (map #(interpret-ast % ctx) args) + ))) + (defn- interpret-synthetic-term [prev-value curr ctx] - (let [type (::ast/type curr)] - (if (= type ::ast/atom) + (let [type (:type curr) + data (:data curr)] + (if (= type :keyword) (if (::data/struct prev-value) - (if (contains? prev-value (:value curr)) - (get prev-value (:value curr)) + (if (contains? prev-value (first data)) + (get prev-value (first data)) (if (= (::data/type prev-value) ::data/ns) (throw (ex-info (str "Namespace error: no member " (:value curr) " in ns " (::data/name prev-value)) {:ast curr})) (throw (ex-info (str "Struct error: no member " (:value curr)) {:ast curr})))) - (get prev-value (:value curr))) - (call-fn prev-value (interpret-ast curr ctx) ctx)))) + (get prev-value (first data))) + (call-fn prev-value (interpret-args curr ctx) ctx)))) (defn- interpret-synthetic [ast ctx] - (let [terms (:terms ast) - first (first terms) - second (second terms) - rest (rest (rest terms)) - first-term-type (::ast/type first) - first-val (if (= first-term-type ::ast/atom) - (interpret-called-kw first second ctx) - (interpret-synthetic-term (interpret-ast first ctx) second ctx))] - (reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest))) + (let [data (:data ast) + first-term (first data) + terms (-> data second :data)] + (if terms + (let [second-term (first terms) + rest (rest terms) + first-val (if (= (:type first) :keyword) + (interpret-called-kw first-term second-term ctx) + (interpret-synthetic-term (interpret-ast first-term ctx) second-term ctx))] + (reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest)) + (do + ;(println "interpreting " (:type first-term)) + (interpret-ast first-term ctx))))) (defn- interpret-fn [ast ctx] ;; TODO: fix context/closure (no cycles)? (let [name (:name ast) @@ -548,23 +631,26 @@ (swap! process #(assoc % :status :dead)))) pid)) +(defn- interpret-literal [ast] (-> ast :data first)) + (defn interpret-ast [ast ctx] - (case (::ast/type ast) - ::ast/self self + (println "interpreting ast type" (:type ast)) + ;(println "AST: " ast) + (case (:type ast) - ::ast/atom (:value ast) + (:nil :true :false :number :string :keyword) (interpret-literal ast) - ::ast/word (resolve-word ast ctx) + :let (interpret-let ast ctx) - ::ast/let (interpret-let ast ctx) + :if (interpret-if ast ctx) - ::ast/if (interpret-if ast ctx) + :word (resolve-word ast ctx) - ::ast/match (interpret-match ast ctx) + :synthetic (interpret-synthetic ast ctx) - ::ast/cond (interpret-cond ast ctx) + :match (interpret-match ast ctx) - ::ast/synthetic (interpret-synthetic ast ctx) + :cond (interpret-cond ast ctx) ::ast/fn (interpret-fn ast ctx) @@ -591,7 +677,7 @@ ::ast/loop (interpret-loop ast ctx) - ::ast/block + :block (let [exprs (:exprs ast) inner (pop exprs) last (peek exprs) @@ -599,8 +685,8 @@ (run! #(interpret-ast % ctx) inner) (interpret-ast last ctx)) - ::ast/script - (let [exprs (:exprs ast) + :script + (let [exprs (:data ast) inner (pop exprs) last (peek exprs)] (run! #(interpret-ast % ctx) inner) @@ -609,16 +695,13 @@ ;; note that, excepting tuples and structs, ;; runtime representations are bare ;; tuples are vectors with a special first member - ::ast/tuple - (let [members (:members ast)] - (into - [(if (:partial ast) ::data/partial ::data/tuple)] - (map #(interpret-ast % ctx)) members)) + :tuple + (let [members (:data ast)] + (into [::data/tuple] (map #(interpret-ast % ctx)) members)) ::ast/list (interpret-list ast ctx) - ::ast/set - (interpret-set ast ctx) + ::ast/set (interpret-set ast ctx) ::ast/dict (interpret-dict ast ctx) @@ -660,14 +743,14 @@ process (process/new-process)] (process/start-vm) (with-bindings {#'self (:pid @process)} - (let [result (interpret-ast (::parser/ast parsed) base-ctx)] + (let [result (interpret-ast parsed base-ctx)] (swap! process #(assoc % :status :dead)) (process/stop-vm) result))) (catch clojure.lang.ExceptionInfo e (process/stop-vm) (println "Ludus panicked!") - (println "On line" (get-in (ex-data e) [:ast :token ::token/line])) + (println "On line" (get-in (ex-data e) [:ast :token :line])) (println (ex-message e)) (pp/pprint (ex-data e))))) @@ -699,30 +782,30 @@ ))))) -(comment +(do (process/start-vm) (def source " - let #{a, a} = #{:a 1} - a - ") + id (1) + ") (println "") (println "****************************************") (println "*** *** NEW INTERPRETATION *** ***") (println "") - (let [result (-> source - (scanner/scan) - (parser/parse) - (interpret-safe) - (show/show) + (let [result (->> source + scanner/scan + :tokens + (p/apply-parser g/script) + interpret-safe + ;(show/show) )] + (println result) result)) (comment " Left to do: - x if-let pattern * improve panics * add location info for panics * refactor calling keywords diff --git a/src/ludus/interpreter_new.clj b/src/ludus/interpreter_new.clj new file mode 100644 index 0000000..95b3f0b --- /dev/null +++ b/src/ludus/interpreter_new.clj @@ -0,0 +1,41 @@ +(ns ludus.interpreter-new + (:require + [ludus.grammar :as g] + [ludus.parser-new :as p] + [ludus.scanner :as s])) + +(def source + " +foo (1, _) + " + ) + +(def tokens (-> source s/scan :tokens)) + +(def result (p/apply-parser g/script tokens)) + +(-> result :data) + +(defn report [node] + (when (p/fail? node) (p/err-msg node)) + 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) + +(def my-data (-> result + clean + tap + )) + +(println my-data) diff --git a/src/ludus/parser_new.clj b/src/ludus/parser_new.clj index 6dfc8b5..981faeb 100644 --- a/src/ludus/parser_new.clj +++ b/src/ludus/parser_new.clj @@ -253,7 +253,7 @@ (:ok :group :quiet) {:status :group :type name - :data (vec (concat [first-result] (data rest-result))) + :data (vec (concat (:data first-result) (data rest-result))) :token (first tokens) :remaining (remaining rest-result)} diff --git a/src/ludus/prelude.clj b/src/ludus/prelude.clj index d2fb63e..707d760 100644 --- a/src/ludus/prelude.clj +++ b/src/ludus/prelude.clj @@ -95,10 +95,13 @@ :body get}) (def draw {:name "draw" - ::data/type ::data/clj - :body d/ludus-draw}) + ::data/type ::data/clj + :body d/ludus-draw}) -(def prelude {"eq" eq +(def prelude { + "foo" :foo + "bar" :bar + "eq" eq "add" add "print" print- "sub" sub From b504370d9649cce452930aaa675887b34d5e7ee7 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Sun, 21 May 2023 23:58:54 -0400 Subject: [PATCH 21/43] Keep knocking 'em down: fns, loops, pipelines work --- src/ludus/compile.clj | 10 +- src/ludus/grammar.clj | 2 +- src/ludus/interpreter.clj | 357 ++++++++++++++++++++-------------- src/ludus/interpreter_new.clj | 7 +- src/ludus/parser_new.clj | 10 +- src/ludus/prelude.clj | 39 ++++ src/ludus/show.clj | 40 ++-- 7 files changed, 280 insertions(+), 185 deletions(-) diff --git a/src/ludus/compile.clj b/src/ludus/compile.clj index b732707..66ce67e 100644 --- a/src/ludus/compile.clj +++ b/src/ludus/compile.clj @@ -16,11 +16,11 @@ What sorts of compiling and validation do we want to do? Be specific. - check used names are bound (validation) - - check bound names are available (validation) - - check `recur` is only ever in `loop` and in `fn` bodies (validation) + - check bound names are free (validation) + - check `recur` is only ever in `loop` (and in `fn` bodies?), in tail position (validation) - separate function arities into different functions (optimization) - - desugar partially applied functions (simplification) - - desugar keyword entry shorthand (simplification) + - desugar partially applied functions (?) (simplification) + - desugar keyword entry shorthand (?) (simplification) - flag tail calls for optimization (optimization) - direct tail calls - through different expressions @@ -29,6 +29,6 @@ - cond - match - let - - check ns access + - check ns access (validation) ") \ No newline at end of file diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 79a35dd..735497a 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -163,7 +163,7 @@ (def synthetic (group (order-1 :synthetic [synth-root (zero+ synth-term)]))) -(def fn-clause (group (order-0 :fn-clause [tuple-pattern (maybe constraint) (quiet :rarrow) expression]))) +(def fn-clause (group (order-1 :fn-clause [tuple-pattern (maybe constraint) (quiet :rarrow) expression]))) (def fn-entry (order-1 :fn-entry [fn-clause terminators])) diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index 6ac3138..dfe24dc 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -57,31 +57,35 @@ ))))))) (defn- match-tuple [pattern value ctx-vol] - (cond - (not (vector? value)) {:success false :reason "Could not match non-tuple value to tuple"} - - (not (= ::data/tuple (first value))) {:success false :reason "Could not match list to tuple"} - - (= ::ast/splat (::ast/type (last (:members pattern)))) - (match-splatted-tuple pattern value ctx-vol) - - (not (= (:length pattern) (dec (count value)))) - {:success false :reason "Cannot match tuples of different lengths"} - - (= 0 (:length pattern) (dec (count value))) {:success true :ctx {}} - - :else - (let [members (:members pattern) - ctx-diff (volatile! @ctx-vol)] - (loop [i (:length pattern)] - (if (= 0 i) - {:success true :ctx @ctx-diff} - (let [match? (match (nth members (dec i)) (nth value i) ctx-diff)] - (if (:success match?) - (do - (vswap! ctx-diff #(merge % (:ctx match?))) - (recur (dec i))) - {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))}))))))) + ;(println "\n\n\n**********Matching tuple") + ;(println "*****Value: " value) + ;(println "*****Pattern: " pattern) + (let [members (:data pattern) + length (count members)] + (cond + (not (vector? value)) {:success false :reason "Could not match non-tuple value to tuple"} + + (not (= ::data/tuple (first value))) {:success false :reason "Could not match list to tuple"} + + (= ::ast/splat (::ast/type (last members))) + (match-splatted-tuple pattern value ctx-vol) + + (not (= length (dec (count value)))) + {:success false :reason "Cannot match tuples of different lengths"} + + (= 0 length (dec (count value))) {:success true :ctx {}} + + :else + (let [ctx-diff (volatile! @ctx-vol)] + (loop [i length] + (if (= 0 i) + {:success true :ctx @ctx-diff} + (let [match? (match (nth members (dec i)) (nth value i) ctx-diff)] + (if (:success match?) + (do + (vswap! ctx-diff #(merge % (:ctx match?))) + (recur (dec i))) + {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))})))))))) (defn- match-list [pattern value ctx-vol] (cond @@ -128,7 +132,7 @@ (let [match? (match (kw members) (kw value) ctx-diff)] (if (:success match?) (do - (println (:ctx match?)) + ;(println (:ctx match?)) (vswap! ctx-diff #(merge % (:ctx match?))) (recur (dec i))) {:success false :reason (str "Could not match " pattern " with " value " at key " kw " because " (:reason match?))})) @@ -160,49 +164,17 @@ {:success false :reason (str "Could not match " pattern " with " value " at key " kw " because " (:reason match?))})) {:success false :reason (str "Could not match " pattern " with " value " at key " kw ", because there is no value at " kw)}))))))) -(defn- get-type [value] - (let [t (type value)] - (cond - (nil? value) :nil - - (= clojure.lang.Keyword t) :keyword - - (= java.lang.Long t) :number - - (= java.lang.Double t) :number - - (= java.lang.String t) :string - - (= java.lang.Boolean t) :boolean - - (= clojure.lang.PersistentHashSet t) :set - - ;; tuples and lists - (= clojure.lang.PersistentVector t) - (if (= ::data/tuple (first value)) :tuple :list) - - ;; structs dicts namespaces refs - (= clojure.lang.PersistentArrayMap t) - (cond - (::data/dict value) :dict - (::data/struct value) :struct - :else :none - ) - - ))) - -(get-type [::data/tuple]) - (defn- match-typed [pattern value ctx] (let [data (:data pattern) name (-> data first :data) type (-> data second :data)] (cond (contains? ctx name) {:success false :reason (str "Name " name "is already bound") :code :name-error} - (not (= type (get-type value))) {:success false :reason (str "Could not match " pattern " with " value ", because types do not match")} + (not (= type (prelude/get-type value))) {:success false :reason (str "Could not match " pattern " with " value ", because types do not match")} :else {:success true :ctx {name value}}))) (defn- match [pattern value ctx-vol] + ;(println "Matching " value " with pattern type " (:type pattern)) (let [ctx @ctx-vol] (case (:type pattern) (:placeholder :ignored) @@ -223,15 +195,15 @@ :typed (match-typed pattern value ctx) - :tuple (match-tuple pattern value ctx-vol) + :tuple-pattern (match-tuple pattern value ctx-vol) - :list (match-list pattern value ctx-vol) + :list-pattern (match-list pattern value ctx-vol) - :dict (match-dict pattern value ctx-vol) + :dict-pattern (match-dict pattern value ctx-vol) - :struct (match-struct pattern value ctx-vol) + :struct-pattern (match-struct pattern value ctx-vol) - (throw (ex-info "Unknown pattern on line " {:pattern pattern}))))) + (throw (ex-info "Unknown pattern on line " {:pattern pattern :value value}))))) (defn- update-ctx [ctx new-ctx] (merge ctx new-ctx)) @@ -294,13 +266,15 @@ match? (match pattern value new-ctx) success (:success match?) clause-ctx (:ctx match?)] - (if success - (do - (vswap! new-ctx #(merge % clause-ctx)) - (if constraint - (if (interpret-ast constraint new-ctx) - (interpret-ast body new-ctx) - (recur (first clauses) (rest clauses))) + (if success + (if constraint + (if (interpret-ast constraint (volatile! clause-ctx)) + (do + (vswap! new-ctx #(merge % clause-ctx)) + (interpret-ast body new-ctx)) + (recur (first clauses) (rest clauses))) + (do + (vswap! new-ctx #(merge % clause-ctx)) (interpret-ast body new-ctx))) (recur (first clauses) (rest clauses)))) (throw (ex-info "Match Error: No match found" {:ast ast})))))) @@ -323,56 +297,88 @@ (interpret-ast body ctx) (recur (first clauses) (rest clauses)))))))) -(defn- interpret-called-kw [kw tuple ctx] - ;; TODO: check this statically - (if (not (= 1 (:length tuple))) - (throw (ex-info "Called keywords must be unary" {:ast kw})) - (let [kw (interpret-ast kw ctx) - map (second (interpret-ast tuple ctx))] - (if (::data/struct map) - (if (contains? map kw) - (kw map) - (if (= (::data/type map) ::data/ns) - (throw (ex-info (str "Namespace error: no member " kw " in ns " (::data/name map)) {:ast kw})) - (throw (ex-info (str "Struct error: no member at " kw) {:ast kw})))) - (get map kw))))) +(defn- validate-args [args] + (>= 1 (count (filter #(= :placeholder (:type %)) args)))) -(defn- call-fn [lfn tuple ctx] +(defn- partial? [args] + (some #(= :placeholder (:type %)) args)) + +(defn- interpret-called-kw [kw tuple ctx] + (let [members (:data tuple) + length (count members)] + ;; TODO: check this statically + (cond + (not (= 1 length)) + (throw (ex-info "Called keywords must be unary" {:ast tuple})) + + (partial? tuple) + (throw (ex-info "Called keywords may not be partially applied" {:ast tuple})) + + :else + (let [kw (interpret-ast kw ctx) + map (second (interpret-ast tuple ctx))] + (if (::data/struct map) + (if (contains? map kw) + (kw map) + (if (= (::data/type map) ::data/ns) + (throw (ex-info (str "Namespace error: no member " kw " in ns " (::data/name map)) {:ast kw})) + (throw (ex-info (str "Struct error: no member at " kw) {:ast kw})))) + (get map kw)))))) + +(defn- call-fn [lfn args ctx] (cond - (= ::data/partial (first tuple)) + (= ::data/partial (first args)) {::data/type ::data/clj :name (str (:name lfn) "{partial}") :body (fn [arg] (call-fn lfn - (concat [::data/tuple] (replace {::data/placeholder arg} (rest tuple))) + (concat [::data/tuple] (replace {::data/placeholder arg} (rest args))) ctx))} - (= (::data/type lfn) ::data/clj) (apply (:body lfn) (next tuple)) + (= (::data/type lfn) ::data/clj) (apply (:body lfn) (next args)) (= (::data/type lfn) ::data/fn) (let [clauses (:clauses lfn) closed-over (:ctx lfn)] (loop [clause (first clauses) clauses (rest clauses)] + ;(println "Matching clause " clause) + ;(println "With args " args) (if clause - (let [pattern (:pattern clause) - body (:body clause) + (let [pattern (first clause) + constraint (if (= 3 (count clause)) + (second clause) + nil) + body (peek clause) fn-ctx (volatile! {::parent closed-over}) - match? (match pattern tuple fn-ctx) + match? (match pattern args fn-ctx) success (:success match?) - clause-ctx (:ctx match?)] + clause-ctx (:ctx match?) + vclause (volatile! (assoc clause-ctx ::parent closed-over))] + ;(println "Pattern: " pattern) + ;(println "Body: " body) (if success - (do - (vswap! fn-ctx #(merge % clause-ctx)) - (interpret-ast body fn-ctx)) + (if constraint + (if (do + ;(println "######### Testing constraint") + ;(println "Context: " clause-ctx) + (interpret-ast constraint vclause)) + (do + ;(println "passed constraint") + (vswap! fn-ctx #(merge % clause-ctx)) + (interpret-ast body fn-ctx)) + (recur (first clauses) (rest clauses))) + (do + (vswap! fn-ctx #(merge % clause-ctx)) + (interpret-ast body fn-ctx))) (recur (first clauses) (rest clauses)))) (throw (ex-info "Match Error: No match found" {:ast (:ast lfn)}))))) (keyword? lfn) - (if (= 2 (count tuple)) - (let [target (second tuple) kw lfn] + (if (= 2 (count args)) + (let [target (second args) kw lfn] (if (::data/struct target) (if (contains? target kw) (kw target) @@ -385,24 +391,20 @@ :else (throw (ex-info "I don't know how to call that" {:ast lfn})))) -(defn- validate-args [args] - (>= 1 (count (filter #(= :placeholder (:type %)) args)))) - -(defn- partial? [args] - (some #(= :placeholder (:type %)) args)) - -(defn- interpret-args [ast ctx] - (let [members (:data ast)] - (if (partial? args) - (if (validate-args) - () ; do the thing - (throw (ex-info "Partially applied functions may only take a single argument"))) - (map #(interpret-ast % ctx) args) - ))) +(defn- interpret-args [args ctx] + ;(println "interpreting arg" args) + (if (partial? args) + (if (validate-args args) + (into [::data/partial] (map #(interpret-ast % ctx)) args) ; do the thing + (throw (ex-info "Partially applied functions may only take a single argument" {:ast args}))) + (into [::data/tuple] (map #(interpret-ast % ctx)) args)) + ) (defn- interpret-synthetic-term [prev-value curr ctx] (let [type (:type curr) data (:data curr)] + ;(println "interpreting synthetic type " type) + ;(println "interpreting synthetic node " curr) (if (= type :keyword) (if (::data/struct prev-value) (if (contains? prev-value (first data)) @@ -411,24 +413,26 @@ (throw (ex-info (str "Namespace error: no member " (:value curr) " in ns " (::data/name prev-value)) {:ast curr})) (throw (ex-info (str "Struct error: no member " (:value curr)) {:ast curr})))) (get prev-value (first data))) - (call-fn prev-value (interpret-args curr ctx) ctx)))) + (call-fn prev-value (interpret-args data ctx) ctx)))) (defn- interpret-synthetic [ast ctx] + ;;(println "interpreting synthetic " ast) (let [data (:data ast) - first-term (first data) - terms (-> data second :data)] - (if terms - (let [second-term (first terms) - rest (rest terms) - first-val (if (= (:type first) :keyword) - (interpret-called-kw first-term second-term ctx) - (interpret-synthetic-term (interpret-ast first-term ctx) second-term ctx))] - (reduce #(interpret-synthetic-term %1 %2 ctx) first-val rest)) + root (first data) + terms (rest data)] + ;(println "!!!!!!!!!Interpreting synthetic w/ root " (:data root)) + (if (seq terms) (do - ;(println "interpreting " (:type first-term)) - (interpret-ast first-term ctx))))) + ;;(println "I've got terms!: " terms) + (let [first-term (first terms) + remaining (rest terms) + first-val (if (= (:type root) :keyword) + (interpret-called-kw root first-term ctx) + (interpret-synthetic-term (interpret-ast root ctx) first-term ctx))] + (reduce #(interpret-synthetic-term %1 %2 ctx) first-val remaining))) + (interpret-ast root ctx)))) -(defn- interpret-fn [ast ctx] ;; TODO: fix context/closure (no cycles)? +(defn- interpret-fn-inner [ast ctx] ;; TODO: fix context/closure (no cycles)? (let [name (:name ast) clauses (:clauses ast)] (if (= name ::ast/anon) @@ -447,11 +451,44 @@ (vswap! ctx update-ctx {name fn}) fn)))))) +(defn- build-fn + ([ast ctx name clauses] (build-fn ast ctx name clauses nil)) + ([ast ctx name clauses docstring] + (let [fnn {::data/type ::data/fn + :name name + :ast ast + :clauses clauses + :ctx ctx + :doc docstring}] + (if (= name :anon) + fnn + (if (contains? @ctx name) + (throw (ex-info (str "Name " name " is already bound") {:ast ast})) + (do + (vswap! ctx update-ctx {name fnn}) + fnn)))))) + +(defn- build-named-fn [ast ctx data] + (let [name (-> data first :data first) + body (-> data second) + compound? (= :compound (:type body))] + (if compound? + (if (= :string (-> body :data first :type)) + (build-fn ast ctx name (map :data (rest (:data body))) (-> body :data first :data)) + (build-fn ast ctx name (map :data (:data body)))) + (build-fn ast ctx name [(:data body)])))) + +(defn- interpret-fn [ast ctx] + (let [data (:data ast)] + (case (:type (first data)) + :fn-clause (build-fn ast ctx :anon (-> data first :data)) + :named (build-named-fn ast ctx (-> data first :data))))) + (defn- interpret-do [ast ctx] - (let [exprs (:exprs ast) - origin (interpret-ast (first exprs) ctx) - fns (rest exprs)] - (reduce #(call-fn (interpret-ast %2 ctx) [::data/tuple %1] ctx) origin fns))) + (let [data (:data ast) + root (interpret-ast (first data) ctx) + fns (rest data)] + (reduce #(call-fn (interpret-ast %2 ctx) [::data/tuple %1] ctx) root fns))) (defn- map-values [f] (map (fn [kv] @@ -501,27 +538,40 @@ ref))) (defn- interpret-loop [ast ctx] - (let [tuple (interpret-ast (:expr ast) ctx) - clauses (:clauses ast)] + (let [data (:data ast) + tuple (interpret-ast (first data) ctx) + loop-type (-> data second :type) + clauses (if (= loop-type :fn-clause) + [(-> data second :data)] + (into [] (map :data) (-> data second :data)))] (loop [input tuple] (let [output (loop [clause (first clauses) clauses (rest clauses)] (if clause - (let [pattern (:pattern clause) - body (:body clause) + (let [pattern (first clause) + constraint (if (= 3 (count clause)) + (second clause) + nil) + body (peek clause) new-ctx (volatile! {::parent ctx}) match? (match pattern input new-ctx) success (:success match?) clause-ctx (:ctx match?)] (if success - (do - (vswap! new-ctx #(merge % clause-ctx)) - (interpret-ast body new-ctx)) + (if constraint + (if (interpret-ast constraint (volatile! (assoc clause-ctx ::parent ctx))) + (do + (vswap! new-ctx #(merge % clause-ctx)) + (interpret-ast body new-ctx)) + (recur (first clauses) (rest clauses))) + (do + (vswap! new-ctx #(merge % clause-ctx)) + (interpret-ast body new-ctx))) (recur (first clauses) (rest clauses)))) (throw (ex-info (str "Match Error: No match found in loop for " input) {:ast ast}))))] (if (::data/recur output) - (recur (:tuple output)) + (recur (:args output)) output))))) (defn- panic [ast ctx] @@ -633,6 +683,8 @@ (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) @@ -652,11 +704,11 @@ :cond (interpret-cond ast ctx) - ::ast/fn (interpret-fn ast ctx) + :fn (interpret-fn ast ctx) - ::ast/pipeline (interpret-do ast ctx) + :do (interpret-do ast ctx) - ::ast/placeholder ::data/placeholder + :placeholder ::data/placeholder ::ast/ns (interpret-ns ast ctx) @@ -664,21 +716,19 @@ ::ast/ref (interpret-ref ast ctx) - ::ast/panic (panic ast ctx) - ::ast/spawn (interpret-spawn ast ctx) ::ast/send (interpret-send ast ctx) ::ast/receive (interpret-receive ast ctx) - ::ast/recur - {::data/recur true :tuple (interpret-ast (:tuple ast) ctx)} + :recur + {::data/recur true :args (interpret-ast (-> ast :data first) ctx)} - ::ast/loop (interpret-loop ast ctx) + :loop (interpret-loop ast ctx) :block - (let [exprs (:exprs ast) + (let [exprs (:data ast) inner (pop exprs) last (peek exprs) ctx (volatile! {::parent ctx})] @@ -695,7 +745,7 @@ ;; note that, excepting tuples and structs, ;; runtime representations are bare ;; tuples are vectors with a special first member - :tuple + (:tuple :args) (let [members (:data ast)] (into [::data/tuple] (map #(interpret-ast % ctx)) members)) @@ -785,7 +835,13 @@ (do (process/start-vm) (def source " - id (1) + loop (4) with { + (0) -> print (:done) + (x) -> { + print (x) + recur (dec (x)) + } + } ") (println "") @@ -798,11 +854,14 @@ :tokens (p/apply-parser g/script) interpret-safe - ;(show/show) + show/show )] (println result) result)) + +(show/show false) + (comment " Left to do: diff --git a/src/ludus/interpreter_new.clj b/src/ludus/interpreter_new.clj index 95b3f0b..0ec7620 100644 --- a/src/ludus/interpreter_new.clj +++ b/src/ludus/interpreter_new.clj @@ -5,9 +5,8 @@ [ludus.scanner :as s])) (def source - " -foo (1, _) - " + "fn () -> {recur (x)} +" ) (def tokens (-> source s/scan :tokens)) @@ -37,5 +36,3 @@ foo (1, _) clean tap )) - -(println my-data) diff --git a/src/ludus/parser_new.clj b/src/ludus/parser_new.clj index 981faeb..c858d09 100644 --- a/src/ludus/parser_new.clj +++ b/src/ludus/parser_new.clj @@ -7,7 +7,7 @@ (def failing #{:err :none}) -(def passing #{:ok :group :silent}) +(def passing #{:ok :group :quiet}) (defn pass? [{status :status}] (contains? passing status)) @@ -32,7 +32,7 @@ (if (= kw (:type token)) {:status :ok :type kw - :data (if (value token) [(value token)] []) + :data (if (some? (value token)) [(value token)] []) :token token :remaining (rest tokens)} {:status :none :token token :trace [kw] :remaining (rest tokens)}))) @@ -78,7 +78,7 @@ first-result (apply-parser (first parsers) tokens)] (case (:status first-result) (:err :none) - (update (assoc first-result :trace #(conj % name)) :status :none) + (assoc (update first-result :trace #(conj % name)) :status :none) (:ok :quiet :group) (loop [ps (rest parsers) @@ -164,7 +164,9 @@ :quiet (recur (rest ps) results res-rem) (:err :none) - (assoc (update result :trace #(conj % name)) :status :err)))))))}) + (assoc (update result :trace #(conj % name)) :status :err) + + (throw (ex-info (str "Got bad result: " (:status result)) result))))))))}) (defn weak-order [name parsers] {:name name diff --git a/src/ludus/prelude.clj b/src/ludus/prelude.clj index 707d760..a4f7238 100644 --- a/src/ludus/prelude.clj +++ b/src/ludus/prelude.clj @@ -98,7 +98,45 @@ ::data/type ::data/clj :body d/ludus-draw}) +(defn get-type [value] + (let [t (type value)] + (cond + (nil? value) :nil + + (= clojure.lang.Keyword t) :keyword + + (= java.lang.Long t) :number + + (= java.lang.Double t) :number + + (= java.lang.String t) :string + + (= java.lang.Boolean t) :boolean + + (= clojure.lang.PersistentHashSet t) :set + + ;; tuples and lists + (= clojure.lang.PersistentVector t) + (if (= ::data/tuple (first value)) :tuple :list) + + ;; structs dicts namespaces refs + (= clojure.lang.PersistentArrayMap t) + (cond + (::data/type value) (case (::data/type value) + (::data/fn ::data/clj) :fn + ::data/ns :ns) + (::data/dict value) :dict + (::data/struct value) :struct + + :else :none + )))) + +(def type- {:name "type" + ::data/type ::data/clj + :body get-type}) + (def prelude { + "id" id "foo" :foo "bar" :bar "eq" eq @@ -120,4 +158,5 @@ "conj" conj- "get" get- "draw" draw + "type" type }) \ No newline at end of file diff --git a/src/ludus/show.clj b/src/ludus/show.clj index beac45a..82f1fc1 100644 --- a/src/ludus/show.clj +++ b/src/ludus/show.clj @@ -1,7 +1,7 @@ (ns ludus.show (:require - [ludus.data :as data] - [clojure.pprint :as pp])) + [ludus.data :as data] + [clojure.pprint :as pp])) (declare show show-linear show-keyed) @@ -13,13 +13,13 @@ (defn- show-map [v] (cond (or (= (::data/type v) ::data/fn) - (= (::data/type v) ::data/clj)) + (= (::data/type v) ::data/clj)) (str "fn " (:name v)) (= (::data/type v) ::data/ns) (str "ns " (::data/name v) " {" - (apply str (into [] show-keyed (dissoc v ::data/struct ::data/type ::data/name))) - "}") + (apply str (into [] show-keyed (dissoc v ::data/struct ::data/type ::data/name))) + "}") (::data/struct v) (str "@{" (apply str (into [] show-keyed (dissoc v ::data/struct))) "}") @@ -38,25 +38,23 @@ (defn show ([v] - (cond - (string? v) (str "\"" v "\"") - (number? v) (str v) - (keyword? v) (str v) - (boolean? v) (str v) - (nil? v) "nil" - (vector? v) (show-vector v) - (set? v) (show-set v) - (map? v) (show-map v) - :else - (with-out-str (pp/pprint v)) - )) + (cond + (string? v) (str "\"" v "\"") + (number? v) (str v) + (keyword? v) (str v) + (boolean? v) (str v) + (nil? v) "nil" + (vector? v) (show-vector v) + (set? v) (show-set v) + (map? v) (show-map v) + :else + (with-out-str (pp/pprint v)) + )) ([v & vs] (apply str (into [] (comp (map show) (interpose " ")) (concat [v] vs)))) ) (def show-linear (comp (map show) (interpose ", "))) (def show-keyed (comp - (map #(str (show (first %)) " " (show (second %)))) - (interpose ", "))) - -(show {::data/type ::data/fn :name "foo"}) + (map #(str (show (first %)) " " (show (second %)))) + (interpose ", "))) From 65692b611bdfad752b170b90baece347eb3757cc Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Mon, 22 May 2023 00:14:53 -0400 Subject: [PATCH 22/43] make some notes --- src/ludus/compile.clj | 1 + 1 file changed, 1 insertion(+) diff --git a/src/ludus/compile.clj b/src/ludus/compile.clj index 66ce67e..5ead91d 100644 --- a/src/ludus/compile.clj +++ b/src/ludus/compile.clj @@ -30,5 +30,6 @@ - match - let - check ns access (validation) + - check constraints: only use specific fns (checked against a constraint-specific ctx) (validation) ") \ No newline at end of file From 325656530833a925ea1cc907966a35acf5dedba9 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Mon, 22 May 2023 00:16:01 -0400 Subject: [PATCH 23/43] Add separate recur node --- src/ludus/grammar.clj | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 735497a..5d6193f 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -157,7 +157,9 @@ (zero+ arg-entry) (quiet :rparen)]))) -(def synth-root (flat (choice :synth-root [:keyword :word :recur]))) +(def recurr (group (order-1 :recur [(quiet :recur) tuple]))) + +(def synth-root (flat (choice :synth-root [:keyword :word]))) (def synth-term (flat (choice :synth-term [args :keyword]))) @@ -190,13 +192,12 @@ (one+ block-line) (quiet :rbrace)]))) -(def pipeline (order-0 :pipeline [nls? :pipeline])) +(def pipeline (quiet (order-0 :pipeline [nls? :pipeline]))) -(def do-entry (order-0 :do-entry [pipeline expression])) +(def do-entry (order-1 :do-entry [pipeline expression])) (def doo (group (order-1 :do [(quiet :do) expression - ;; should this be zero+? (one+ do-entry) ]))) @@ -230,6 +231,7 @@ spawn receive synthetic + recurr block doo reff From 618d6b856c3920d765c312d06d1a0e9133559723 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Mon, 22 May 2023 00:17:17 -0400 Subject: [PATCH 24/43] Add TODO --- src/ludus/grammar.clj | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 5d6193f..e5f3c9a 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -264,6 +264,8 @@ ;;; REPL +;; TODO: fix this recursive def bullshit problem + (comment (def source "if 1 then 2 else 3" ) From 6cf09fb177b80cbbbe49dd66fd78990f1dcc4703 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Mon, 22 May 2023 16:56:24 -0400 Subject: [PATCH 25/43] Complete interpreter, less process system: spawn, receive --- src/ludus/grammar.clj | 14 ++-- src/ludus/interpreter.clj | 145 ++++++++++++++++++++-------------- src/ludus/interpreter_new.clj | 4 +- src/ludus/process.clj | 74 ++++++++--------- src/ludus/show.clj | 2 +- 5 files changed, 131 insertions(+), 108 deletions(-) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index e5f3c9a..09ff1db 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -137,7 +137,7 @@ (zero+ struct-entry) (quiet :rbrace)]))) -(def dict-term (flat (choice :dict-term [:word pair splat]))) +(def dict-term (flat (choice :dict-term [splat :word pair]))) (def dict-entry (order-1 :dict-entry [dict-term separators])) @@ -246,12 +246,12 @@ (def importt (group (order-1 :import [(quiet :import) :string (quiet :as) :word]))) -(def nss (group (order-1 :nss [(quiet :ns) - :word - (quiet :lbrace) - (quiet (zero+ separator)) - (zero+ struct-entry) - (quiet :rbrace)]))) +(def nss (group (order-1 :ns [(quiet :ns) + :word + (quiet :lbrace) + (quiet (zero+ separator)) + (zero+ struct-entry) + (quiet :rbrace)]))) (def toplevel (flat (choice :toplevel [importt nss expression testt]))) diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index dfe24dc..e13e1f7 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -495,21 +495,10 @@ (let [[k v] kv] [k (f v)])))) -(defn- interpret-ns [ast ctx] - (let [members (:members ast) - name (:name ast)] - (if (contains? @ctx name) - (throw (ex-info (str "ns name " name " is already bound") {:ast ast})) - (let [ns (into - {::data/struct true ::data/type ::data/ns ::data/name name} - (map-values #(interpret-ast % ctx)) - members)] - (vswap! ctx update-ctx {name ns}) - ns)))) - (defn- interpret-import [ast ctx] - (let [path (:path ast) - name (:name ast) + (let [data (:data ast) + path (-> data first :data first) + name (-> data second :data first) file (ludus-resolve :file ctx) from (if (= ::not-found file) :cwd file)] (if (contains? @ctx name) @@ -521,14 +510,14 @@ (throw (ex-info (ex-message e) {:ast ast})) (throw e)))) result (-> source (scanner/scan) (parser/parse) (interpret-file path))] - ;; (pp/pprint @ctx) (vswap! ctx update-ctx {name result}) - ;; (pp/pprint @ctx) result )))) (defn- interpret-ref [ast ctx] - (let [name (:name ast) expr (:expr ast)] + (let [data (:data ast) + name (-> data first :data first) + expr (-> data second)] (when (contains? @ctx name) (throw (ex-info (str "Name " name " is already bound") {:ast ast}))) (let [value (interpret-ast expr ctx) @@ -579,24 +568,25 @@ (defn- list-term [ctx] (fn [list member] - (if (= (::ast/type member) ::ast/splat) - (let [splatted (interpret-ast (:expr member) ctx) - splat-list? (and - (vector? splatted) - (not (= (first splatted) ::data/tuple)))] - (if splat-list? - (concat list splatted) + (if (= (:type member) :splat) + (let [splatted (interpret-ast (-> member :data first) ctx) + splattable? (vector? splatted) + tuple-splat? (= (first splatted) ::data/tuple)] + (if splattable? + (if tuple-splat? + (into [] (concat list (rest splatted))) + (concat list splatted)) (throw (ex-info "Cannot splat non-list into list" {:ast member})))) - (concat list [(interpret-ast member ctx)])))) + (conj list (interpret-ast member ctx))))) (defn- interpret-list [ast ctx] - (let [members (:members ast)] + (let [members (:data ast)] (into [] (reduce (list-term ctx) [] members)))) (defn- set-term [ctx] (fn [set member] - (if (= (::ast/type member) ::ast/splat) - (let [splatted (interpret-ast (:expr member) ctx) + (if (= (:type member) :splat) + (let [splatted (interpret-ast (-> member :data first) ctx) splat-set? (set? splatted)] (if splat-set? (clojure.set/union set splatted) @@ -604,26 +594,68 @@ (conj set (interpret-ast member ctx))))) (defn- interpret-set [ast ctx] - (let [members (:members ast)] + (let [members (:data ast)] (reduce (set-term ctx) #{} members))) (defn- dict-term [ctx] (fn [dict member] - (if (= (::ast/type member) ::ast/splat) - (let [splatted (interpret-ast (:expr member) ctx) - splat-map? (and - (map? splatted) - (::data/dict splatted))] - (if splat-map? - (merge dict splatted) - (throw (ex-info "Cannot splat non-dict into dict" {:ast member})))) - (let [k (first member) v (second member)] - (assoc dict k (interpret-ast v ctx)))))) + (case (:type member) + :splat (let [splatted (interpret-ast (-> member :data first) ctx) + splat-map? (or (::data/dict splatted) + (::data/struct splatted))] + (if splat-map? + (merge dict splatted) + (throw (ex-info "Cannot splat non-dict into dict" {:ast member})))) + :word (let [data (:data member) k (-> data first keyword)] + (assoc dict k (interpret-ast member ctx))) + + :pair (let [data (:data member) k (-> data first :data first) v (second data)] + (assoc dict k (interpret-ast v ctx)))))) (defn- interpret-dict [ast ctx] - (let [members (:members ast)] + (let [members (:data ast)] (assoc (reduce (dict-term ctx) {} members) ::data/dict true))) +(defn- struct-term [ctx] + (fn [struct member] + (case (:type member) + :splat (throw (ex-info "Cannot splat into struct" {:ast member})) + + :word (let [data (:data member) k (-> data first keyword)] + (assoc struct k (interpret-ast member ctx))) + + :pair (let [data (:data member) k (-> data first :data first) v (second data)] + (assoc struct k (interpret-ast v ctx)))))) + +(defn- interpret-struct [ast ctx] + (let [members (:data ast)] + (assoc (reduce (struct-term ctx) {} members) ::data/struct true))) + +(defn- ns-term [ctx] + (fn [ns member] + (case (:type member) + :splat (throw (ex-info "Cannot splat into ns" {:ast member})) + + :word (let [data (:data member) k (-> data first keyword)] + (assoc ns k (interpret-ast member ctx))) + + :pair (let [data (:data member) k (-> data first :data first) v (second data)] + (assoc ns k (interpret-ast v ctx)))))) + +(defn- interpret-ns [ast ctx] + (let [data (:data ast) + name (-> data first :data first) + members (rest data)] + (if (contains? @ctx name) + (throw (ex-info (str "ns name " name " is already bound") {:ast ast})) + (let [ns (merge { + ::data/struct true + ::data/type ::data/ns + ::data/name name} + (reduce (ns-term ctx) {} members))] + (vswap! ctx update-ctx {name ns}) + ns)))) + (defn- interpret-receive [ast ctx] (let [process-atom (get @process/processes self) inbox (promise) @@ -668,7 +700,7 @@ msg)) (defn- interpret-spawn [ast ctx] - (let [expr (:expr ast) + (let [expr (-> ast :data first) process (process/new-process) pid (:pid @process)] (with-bindings {#'self pid} @@ -710,16 +742,14 @@ :placeholder ::data/placeholder - ::ast/ns (interpret-ns ast ctx) + :ns (interpret-ns ast ctx) - ::ast/import (interpret-import ast ctx) + :import (interpret-import ast ctx) - ::ast/ref (interpret-ref ast ctx) + :ref (interpret-ref ast ctx) ::ast/spawn (interpret-spawn ast ctx) - ::ast/send (interpret-send ast ctx) - ::ast/receive (interpret-receive ast ctx) :recur @@ -749,15 +779,14 @@ (let [members (:data ast)] (into [::data/tuple] (map #(interpret-ast % ctx)) members)) - ::ast/list (interpret-list ast ctx) + :list (interpret-list ast ctx) - ::ast/set (interpret-set ast ctx) + :set (interpret-set ast ctx) - ::ast/dict (interpret-dict ast ctx) + :dict (interpret-dict ast ctx) - ::ast/struct - (let [members (:members ast)] - (into {::data/struct true} (map-values #(interpret-ast % ctx)) members)) + :struct + (let [members (:members ast)] (interpret-struct ast ctx)) (throw (ex-info "Unknown AST node type" {:ast ast})))) @@ -777,7 +806,7 @@ process (process/new-process)] (process/start-vm) (with-bindings {#'self (:pid @process)} - (let [result (interpret-ast (::parser/ast parsed) base-ctx)] + (let [result (interpret-ast (::parser/ast parsed) {::parent base-ctx})] (swap! process #(assoc % :status :dead)) (process/stop-vm) result))) @@ -789,7 +818,7 @@ (defn interpret-safe [parsed] (try - (let [base-ctx (volatile! (merge {} prelude/prelude)) + (let [base-ctx (volatile! {::parent (volatile! prelude/prelude)}) process (process/new-process)] (process/start-vm) (with-bindings {#'self (:pid @process)} @@ -835,13 +864,7 @@ (do (process/start-vm) (def source " - loop (4) with { - (0) -> print (:done) - (x) -> { - print (x) - recur (dec (x)) - } - } + ref a = 1 ") (println "") diff --git a/src/ludus/interpreter_new.clj b/src/ludus/interpreter_new.clj index 0ec7620..d22c685 100644 --- a/src/ludus/interpreter_new.clj +++ b/src/ludus/interpreter_new.clj @@ -5,13 +5,13 @@ [ludus.scanner :as s])) (def source - "fn () -> {recur (x)} + "spawn foo " ) (def tokens (-> source s/scan :tokens)) -(def result (p/apply-parser g/script tokens)) +(def result (p/apply-parser g/spawn tokens)) (-> result :data) diff --git a/src/ludus/process.clj b/src/ludus/process.clj index 0259cc7..30926f0 100644 --- a/src/ludus/process.clj +++ b/src/ludus/process.clj @@ -1,6 +1,6 @@ (ns ludus.process - (:require - [ludus.data :as data]) + (:require + [ludus.data :as data]) (:import (java.util.concurrent Executors))) ;; virtual thread patch from https://ales.rocks/notes-on-virtual-threads-and-clojure @@ -20,13 +20,13 @@ (defn new-process [] (let [pid @current-pid process (atom {:pid pid - :queue clojure.lang.PersistentQueue/EMPTY - :inbox nil - :status :occupied - })] - (swap! processes #(assoc % pid process)) - (swap! current-pid inc) - process)) + :queue clojure.lang.PersistentQueue/EMPTY + :inbox nil + :status :occupied + })] + (swap! processes #(assoc % pid process)) + (swap! current-pid inc) + process)) (def vm-state (atom :stopped)) @@ -37,7 +37,7 @@ (defn process-msg [process] ;;(println "processing message" self) (let [q (:queue process) - inbox (:inbox process)] + inbox (:inbox process)] (when (not (realized? inbox)) ;;(println "delivering message in" self) (deliver inbox (peek q)) @@ -45,9 +45,9 @@ (defn run-process [process-atom] (let [process @process-atom - status (:status process) - q (:queue process) - inbox (:inbox process)] + status (:status process) + q (:queue process) + inbox (:inbox process)] ;;(println "running process" self ":" (into [] q)) (when (and (= status :idle) (not-empty q) inbox) (swap! process-atom process-msg)))) @@ -59,10 +59,10 @@ (reset! vm-state :running) (loop [] (when (= @vm-state :running) - (run! run-process (values @processes)) - (recur) - ;; (println "Ludus VM shutting down") - ))))) + (run! run-process (values @processes)) + (recur) + ;; (println "Ludus VM shutting down") + ))))) (defn stop-vm [] (reset! vm-state :stopped) @@ -71,26 +71,26 @@ nil) (def process {"process" { - ::data/struct true - ::data/type ::data/ns - ::data/name "process" + ::data/struct true + ::data/type ::data/ns + ::data/name "process" - :list {::data/type ::data/clj - :name "list" - :body (fn [] (into [] (keys @processes)))} + "list" {::data/type ::data/clj + :name "list" + :body (fn [] (into [] (keys @processes)))} - :info {::data/type ::data/clj - :name "info" - :body (fn [pid] - (let [process @(get @processes pid) - queue (into [] (:queue process))] - (assoc process :queue queue ::data/dict true)))} + "info" {::data/type ::data/clj + :name "info" + :body (fn [pid] + (let [process @(get @processes pid) + queue (into [] (:queue process))] + (assoc process :queue queue ::data/dict true)))} - :flush {::data/type ::data/clj - :name "flush" - :body (fn [pid] - (let [process (get @processes pid) - queue (into [] (:queue @process))] - (swap! process #(assoc % :queue clojure.lang.PersistentQueue/EMPTY)) - queue))} - }}) \ No newline at end of file + "flush" {::data/type ::data/clj + :name "flush" + :body (fn [pid] + (let [process (get @processes pid) + queue (into [] (:queue @process))] + (swap! process #(assoc % :queue clojure.lang.PersistentQueue/EMPTY)) + queue))} + }}) \ No newline at end of file diff --git a/src/ludus/show.clj b/src/ludus/show.clj index 82f1fc1..5cff408 100644 --- a/src/ludus/show.clj +++ b/src/ludus/show.clj @@ -25,7 +25,7 @@ (str "@{" (apply str (into [] show-keyed (dissoc v ::data/struct))) "}") (::data/ref v) ;; TODO: reconsider this - (str "ref:" (::data/name v) " <" (deref (::data/value v)) ">") + (str "ref: " (::data/name v) " [" (deref (::data/value v)) "]") (::data/dict v) (str "#{" (apply str (into [] show-keyed (dissoc v ::data/dict))) "}") From cff0f9b6e855da5b5e17d9dbc46957cc8ff25a39 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Mon, 22 May 2023 17:00:10 -0400 Subject: [PATCH 26/43] Add some todo notes --- TODO.xit | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 TODO.xit diff --git a/TODO.xit b/TODO.xit new file mode 100644 index 0000000..85b82bc --- /dev/null +++ b/TODO.xit @@ -0,0 +1,4 @@ +[ ] Wire up interpreter for spawn and receive +[ ] Write send function +[ ] ---- Investigate weird timing issue in current send implementation +[ ] Investigate with-bindings and virtual threads From c6eeed4f4c7a27f52e65d8883c34718b6353f41d Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Fri, 26 May 2023 15:07:41 -0400 Subject: [PATCH 27/43] 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)) From 776f975d54a146bbee715aacadba22dbf9ffc6ad Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Fri, 26 May 2023 15:21:55 -0400 Subject: [PATCH 28/43] Collate TODOs; comment repl cruft --- TODO.xit | 41 ++++++++++++++++++++++++------ src/ludus/grammar.clj | 52 ++++++++++++++++++++------------------- src/ludus/interpreter.clj | 8 ++---- 3 files changed, 62 insertions(+), 39 deletions(-) diff --git a/TODO.xit b/TODO.xit index 57decd2..99156d3 100644 --- a/TODO.xit +++ b/TODO.xit @@ -1,14 +1,39 @@ -[ ] Wire up interpreter for spawn and receive -[ ] Write send function + +[x] Fix recursive definition problems in grammar.clj + +TODOS from interpreter +[ ] implement tuple splat patterns +[ ] update match-list to use new AST representation +[ ] fix length comparison when pattern includes splats +[ ] update match-dict to use new AST representation +[ ] update match-struct to use new AST representation +[ ] update interpret-receive to use new AST representation +[ ] Check interpret-fn-inner ctx for cycles/bugs + +Re-add processes to the language +[ ] Write send as function +[ ] update interpret-spawn to use new AST representation [ ] ---- Investigate weird timing issue in current send implementation -[ ] Investigate with-bindings and virtual threads - -[ ] Fix recursive definition problems in grammar.clj +[ ] Investigate `with-bindings` and virtual threads +Finish interpreter [ ] Wire up new interpreter to repl, script situation - -[ ] Write compiler - [ ] Merge new interpreter +Write a compiler: desugaring +[ ] `...` to `..._` in tuple & list patterns +[ ] placeholder partial application to anonymous lambda +[ ] word -> :[word] word in pairs (patterns & expressions) + +Write a compiler: correctness +[ ] check for unbound names +[ ] check for re-binding names +[ ] check that recur is in tail position +[ ] check that recur is only called inside loop or fn forms +[ ] check ns accesses + +Write a compiler: optimization +[ ] devise tail call optimization + +Next steps [ ] Get drawing working? diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 26575c4..13c55ee 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -273,37 +273,39 @@ ;;; REPL -(def source - "2" - ) +(comment -(def rule (literal)) + (def source + "if 1 then 2 else 3" + ) -(def tokens (-> source scan/scan :tokens)) + (def rule (literal)) -(def result (apply-parser literal tokens)) + (def tokens (-> source scan/scan :tokens)) + + (def result (apply-parser script 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 fe8f254..2e46db3 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -718,7 +718,7 @@ (defn- interpret-literal [ast] (-> ast :data first)) (defn interpret-ast [ast ctx] - (println "interpreting ast type" (:type ast)) + ;(println "interpreting ast type" (:type ast)) ;(println "AST: " ast) (case (:type ast) @@ -865,9 +865,8 @@ (do - (process/start-vm) (def source " - ref a = 1 + if 1 then 2 else 3 ") (println "") @@ -885,9 +884,6 @@ (println result) result)) - -(show/show false) - (comment " Left to do: From c1b305bc1c34b301d7e2a18a4a30e8146e568ff8 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Fri, 26 May 2023 15:23:12 -0400 Subject: [PATCH 29/43] Fix constraint -> guard --- src/ludus/grammar.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 13c55ee..099de1e 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -174,7 +174,7 @@ (defp synthetic group order-1 [synth-root (zero+ synth-term)]) -(defp fn-clause group order-1 [tuple-pattern (maybe constraint) (quiet :rarrow) expression]) +(defp fn-clause group order-1 [tuple-pattern (maybe guard) (quiet :rarrow) expression]) (defp fn-entry order-1 [fn-clause terminators]) From 35eed84741377236d0c69bc5ceb7a47af09e1e67 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Fri, 26 May 2023 15:24:10 -0400 Subject: [PATCH 30/43] Constraint -> guard --- src/ludus/interpreter.clj | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index 2e46db3..1f97e76 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -261,17 +261,17 @@ (if clause (let [clause-data (:data clause) pattern (first clause-data) - constraint (if (= 3 (count clause-data)) - (second clause-data) - nil) + guard (if (= 3 (count clause-data)) + (second clause-data) + nil) body (peek clause-data) new-ctx (volatile! {::parent ctx}) match? (match pattern value new-ctx) success (:success match?) clause-ctx (:ctx match?)] (if success - (if constraint - (if (interpret-ast constraint (volatile! clause-ctx)) + (if guard + (if (interpret-ast guard (volatile! clause-ctx)) (do (vswap! new-ctx #(merge % clause-ctx)) (interpret-ast body new-ctx)) @@ -350,9 +350,9 @@ ;(println "With args " args) (if clause (let [pattern (first clause) - constraint (if (= 3 (count clause)) - (second clause) - nil) + guard (if (= 3 (count clause)) + (second clause) + nil) body (peek clause) fn-ctx (volatile! {::parent closed-over}) match? (match pattern args fn-ctx) @@ -362,13 +362,13 @@ ;(println "Pattern: " pattern) ;(println "Body: " body) (if success - (if constraint + (if guard (if (do - ;(println "######### Testing constraint") + ;(println "######### Testing guard") ;(println "Context: " clause-ctx) - (interpret-ast constraint vclause)) + (interpret-ast guard vclause)) (do - ;(println "passed constraint") + ;(println "passed guard") (vswap! fn-ctx #(merge % clause-ctx)) (interpret-ast body fn-ctx)) (recur (first clauses) (rest clauses))) @@ -541,17 +541,17 @@ clauses (rest clauses)] (if clause (let [pattern (first clause) - constraint (if (= 3 (count clause)) - (second clause) - nil) + guard (if (= 3 (count clause)) + (second clause) + nil) body (peek clause) new-ctx (volatile! {::parent ctx}) match? (match pattern input new-ctx) success (:success match?) clause-ctx (:ctx match?)] (if success - (if constraint - (if (interpret-ast constraint (volatile! (assoc clause-ctx ::parent ctx))) + (if guard + (if (interpret-ast guard (volatile! (assoc clause-ctx ::parent ctx))) (do (vswap! new-ctx #(merge % clause-ctx)) (interpret-ast body new-ctx)) From 0e9c4036344add6c3b0b6d632b6a3fe0b7cc17aa Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Wed, 31 May 2023 09:30:12 -0400 Subject: [PATCH 31/43] Things, mostly list & tuple splats are correct. --- TODO.xit | 2 + src/ludus/grammar.clj | 4 +- src/ludus/interpreter.clj | 99 +++++++++++++++++++++++---------------- src/ludus/show.clj | 2 +- 4 files changed, 63 insertions(+), 44 deletions(-) diff --git a/TODO.xit b/TODO.xit index 99156d3..049472b 100644 --- a/TODO.xit +++ b/TODO.xit @@ -31,9 +31,11 @@ Write a compiler: correctness [ ] check that recur is in tail position [ ] check that recur is only called inside loop or fn forms [ ] check ns accesses +[ ] splattern is last member in a pattern Write a compiler: optimization [ ] devise tail call optimization Next steps [ ] Get drawing working? +[ ] Add stack traces for panics diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 099de1e..313df73 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -5,7 +5,7 @@ (declare expression pattern) ;(def separator (choice :separator [:comma :newline :break])) -(defp separator [choice] [:comma :newline :break]) +(defp separator choice [:comma :newline :break]) ;(def separators (quiet (one+ separator))) (defp separators quiet one+ separator) @@ -23,7 +23,7 @@ (defp splat group order-1 [(quiet :splat) :word]) ;(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 patt-splat-able 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]))) diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index 1f97e76..28bf5f7 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -36,23 +36,31 @@ (declare interpret-ast match interpret interpret-file) -;; TODO: actually implement this! -(defn- match-splatted-tuple [pattern value ctx-vol] - (let [length (:length pattern) members (:members pattern) +(defn- match-splatted [pattern value ctx-vol] + (let [members (:data pattern) + non-splat (pop members) + splattern (peek members) + length (count members) ctx-diff (volatile! @ctx-vol)] - (if (> length (count value)) - {:success false :reason "Could not match tuple lengths"} - (loop [i 0 ctx {}] + (if (> length (-> value count dec)) + {:success false :reason "Could not match different lengths"} + (loop [i 0] (if (= (dec length) i) - ( - ;; TODO: write the actual splat here - ;; check if the name is already bound - ;; then pack everything into a list - ;; and return success with the list bound to the name - ) - (let [match? (match (nth members i) (nth value (inc i)) ctx-diff)] + (let [last-binding (-> splattern :data first) + binding-type (:type last-binding)] + (if (= binding-type :word) + (let [splat-ctx (:ctx (match + last-binding + (into [::data/list] (subvec value (inc i))) + ctx-diff))] + {:success true :ctx (merge @ctx-diff splat-ctx)}) + {:success true :ctx @ctx-diff})) + (let [match? (match (nth non-splat i) (nth value (inc i)) ctx-diff)] (if (:success match?) - (recur (inc i) (vswap! ctx-diff #(merge % (:ctx match?)))) + (do + (vswap! ctx-diff #(merge % (:ctx match?))) + (println "current context: " (dissoc @ctx-diff ::parent)) + (recur (inc i))) {:success :false :reason (str "Could not match " pattern " with " value)} ))))))) @@ -67,8 +75,8 @@ (not (= ::data/tuple (first value))) {:success false :reason "Could not match list to tuple"} - (= ::ast/splat (::ast/type (last members))) - (match-splatted-tuple pattern value ctx-vol) + (= :splattern (:type (peek members))) + (match-splatted pattern value ctx-vol) (not (= length (dec (count value)))) {:success false :reason "Cannot match tuples of different lengths"} @@ -88,30 +96,38 @@ {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))})))))))) ;; TODO: update this to use new AST representation +;; TODO: update this to reflect first element of list is ::data/list (defn- match-list [pattern value ctx-vol] - (cond - (not (vector? value)) {:success false :reason "Could not match non-list value to list"} + (let [members (:data pattern) + splatted? (= :splattern (-> members peek :type))] + (cond + (not (vector? value)) + {:success false :reason "Could not match non-list value to list"} + + (= ::data/tuple (first value)) + {:success false :reason "Could not match tuple value to list pattern"} - (= ::data/tuple (first value)) {:success false :reason "Could not match tuple value to list pattern"} - - ;; TODO: fix this with splats - (not (= (count (:members pattern)) (count value))) - {:success false :reason "Cannot match lists of different lengths"} - - (= 0 (count (:members pattern)) (count value)) {:success true :ctx {}} - - :else - (let [members (:members pattern) - ctx-diff (volatile! @ctx-vol)] - (loop [i (dec (count members))] - (if (> 0 i) - {:success true :ctx @ctx-diff} - (let [match? (match (nth members i) (nth value i) ctx-diff)] - (if (:success match?) - (do - (vswap! ctx-diff #(merge % (:ctx match?))) - (recur (dec i))) - {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))}))))))) + splatted? + (match-splatted pattern value ctx-vol) + + ;; TODO: fix this with splats + (not= (count members) (dec (count value))) + {:success false :reason "Cannot match lists of different lengths"} + + (= 0 (count members) (dec (count value))) + {:success true :ctx {}} + + :else + (let [ctx-diff (volatile! @ctx-vol)] + (loop [i (dec (count members))] + (if (> 0 i) + {:success true :ctx @ctx-diff} + (let [match? (match (nth members i) (nth value (inc i)) ctx-diff)] + (if (:success match?) + (do + (vswap! ctx-diff #(merge % (:ctx match?))) + (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] @@ -574,14 +590,14 @@ tuple-splat? (= (first splatted) ::data/tuple)] (if splattable? (if tuple-splat? - (into [] (concat list (rest splatted))) + (into [::data/list] (concat list (rest splatted))) (concat list splatted)) (throw (ex-info "Cannot splat non-list into list" {:ast member})))) (conj list (interpret-ast member ctx))))) (defn- interpret-list [ast ctx] (let [members (:data ast)] - (into [] (reduce (list-term ctx) [] members)))) + (into [::data/list] (reduce (list-term ctx) [] members)))) (defn- set-term [ctx] (fn [set member] @@ -866,7 +882,8 @@ (do (def source " - if 1 then 2 else 3 + let (...a) = (1, 2, 3) + a ") (println "") diff --git a/src/ludus/show.clj b/src/ludus/show.clj index 5cff408..87f3e7e 100644 --- a/src/ludus/show.clj +++ b/src/ludus/show.clj @@ -8,7 +8,7 @@ (defn- show-vector [v] (if (= (first v) ::data/tuple) (str "(" (apply str (into [] show-linear (next v))) ")") - (str "[" (apply str (into [] show-linear v)) "]"))) + (str "[" (apply str (into [] show-linear (next v))) "]"))) (defn- show-map [v] (cond From 6c38c437277c0f67a6de08c9746d4ec8987e9d7e Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Wed, 31 May 2023 11:31:04 -0400 Subject: [PATCH 32/43] Get dict splats working, fix match-typed --- TODO.xit | 3 ++ src/ludus/grammar.clj | 2 +- src/ludus/interpreter.clj | 105 ++++++++++++++++++++++++++++---------- 3 files changed, 82 insertions(+), 28 deletions(-) diff --git a/TODO.xit b/TODO.xit index 049472b..15c3284 100644 --- a/TODO.xit +++ b/TODO.xit @@ -32,6 +32,9 @@ Write a compiler: correctness [ ] check that recur is only called inside loop or fn forms [ ] check ns accesses [ ] splattern is last member in a pattern +[ ] -----List/Tuple +[ ] -----Dict/Struct/Set +[ ] prevent import cycles Write a compiler: optimization [ ] devise tail call optimization diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 313df73..095aae0 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -45,7 +45,7 @@ (zero+ tuple-pattern-entry) (quiet :rbracket)]) -(defp pair-pattern order-0 [:keyword #'pattern]) +(defp pair-pattern group weak-order [:keyword pattern]) (defp dict-pattern-term flat choice [pair-pattern :word splattern]) diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index 28bf5f7..d0f03ba 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -129,33 +129,84 @@ (recur (dec i))) {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))})))))))) +(defn- member->kv [map member] + (let [type (:type member) + data (:data member)] + (case type + :word + (assoc map (keyword (first data)) member) + + :pair-pattern + (assoc map (-> data first :data first) (second data)) + + map ;;ignore splats + ))) + +(defn- pattern-to-map [pattern] + (let [members (:data pattern)] + (reduce member->kv {} members))) + ;; TODO: update this to match new AST representation -(defn- match-dict [pattern value ctx-vol] - (cond - (not (map? value)) - {:success false :reason "Could not match non-dict value to dict pattern"} +(defn- match-dict [pattern dict ctx-vol] + (let [ + members (:data pattern) + pattern-map (pattern-to-map pattern) + kws (keys pattern-map)] + ;(println "Matching with " pattern-map) + (cond + (not (map? dict)) + {:success false :reason "Could not match non-dict value to dict pattern"} + + (not (::data/dict dict)) + {:success false :reason "Cannot match non-dict data types to a dict pattern"} - (not (::data/dict value)) - {:success false :reason "Cannot match non-dict data types to a dict pattern"} + (empty? members) + {:success true :ctx {}} + + :else + (let [ctx-diff (volatile! @ctx-vol) + splat? (= :splattern (-> members peek :type)) + length (count kws)] + (if splat? (println "Pattern has splat!!")) + (loop [i 0] + (cond + (> length i) + (let [kw (nth kws i) + pattern-at (kw pattern-map) + value (kw dict)] + (if (contains? dict kw) + (let [match? (match pattern-at value ctx-diff)] + (if (:success match?) + (do + (vswap! ctx-diff #(merge % (:ctx match?))) + (recur (inc i))) + {:success false + :reason (str "Could not match " pattern " with value " dict " at key " kw " because " (:reason match?))} + )) + {:success false + :reason (str "Could not match " pattern " with " dict " at key " kw " because there is no value at " kw)})) - :else - (let [members (:members pattern) - kws (keys members) - ctx-diff (volatile! @ctx-vol)] - (loop [i (dec (count kws))] - (if (> 0 i) - {:success true :ctx @ctx-diff} - (let [kw (nth kws i)] - (if (contains? value kw) - (let [match? (match (kw members) (kw value) ctx-diff)] - (if (:success match?) - (do - ;(println (:ctx match?)) - (vswap! ctx-diff #(merge % (:ctx match?))) - (recur (dec i))) - {:success false :reason (str "Could not match " pattern " with " value " at key " kw " because " (:reason match?))})) - {:success false - :reason (str "Could not match " pattern " with " value " at key " kw " because there is no value at " kw)}))))))) + splat? + (let [splat (-> members peek) + splat-data (-> splat :data first) + splat-type (-> splat-data :type)] + (println "!!!!Matching splat") + (if (= :word splat-type) + (let [unmatched (apply dissoc dict kws) + match? (match splat-data unmatched ctx-diff)] + (println "Splatting " unmatched "\ninto " ) + (if (:success match?) + {:success true :ctx (merge @ctx-diff (:ctx match?))} + {:success false + :reason (str "Could not match " pattern " with value " dict " because " (:reason match?))} + )) + {:success true :ctx @ctx-diff} + )) + + :else + {:success true :ctx @ctx-diff} + + )))))) ;; TODO: update this to use new AST representation (defn- match-struct [pattern value ctx-vol] @@ -185,8 +236,8 @@ (defn- match-typed [pattern value ctx] (let [data (:data pattern) - name (-> data first :data) - type (-> data second :data)] + name (-> data first :data first) + type (-> data second :data first)] (cond (contains? ctx name) {:success false :reason (str "Name " name "is already bound") :code :name-error} (not (= type (prelude/get-type value))) {:success false :reason (str "Could not match " pattern " with " value ", because types do not match")} @@ -882,7 +933,7 @@ (do (def source " - let (...a) = (1, 2, 3) + let #{:a a as :number} = #{:a 1} a ") From e27e5a4c1a9c17bda55c5643c85237db681225b0 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Wed, 31 May 2023 11:37:39 -0400 Subject: [PATCH 33/43] Add typed shorthand to dicts --- src/ludus/grammar.clj | 6 +++--- src/ludus/interpreter.clj | 5 ++++- src/ludus/interpreter_new.clj | 4 ++-- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 095aae0..97634e8 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -47,7 +47,9 @@ (defp pair-pattern group weak-order [:keyword pattern]) -(defp dict-pattern-term flat choice [pair-pattern :word splattern]) +(defp typed group weak-order [:word (quiet :as) :keyword]) + +(defp dict-pattern-term flat choice [pair-pattern :word typed splattern]) (defp dict-pattern-entry weak-order [dict-pattern-term separators]) @@ -65,8 +67,6 @@ (defp guard order-0 [(quiet :when) expression]) -(defp typed group weak-order [:word (quiet :as) :keyword]) - (defp pattern flat choice [literal :ignored :placeholder diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index d0f03ba..d09ac97 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -139,6 +139,9 @@ :pair-pattern (assoc map (-> data first :data first) (second data)) + :typed + (assoc map (-> data first :data first keyword) member) + map ;;ignore splats ))) @@ -933,7 +936,7 @@ (do (def source " - let #{:a a as :number} = #{:a 1} + let #{a as :number} = #{:a 1} a ") diff --git a/src/ludus/interpreter_new.clj b/src/ludus/interpreter_new.clj index d22c685..3c7c268 100644 --- a/src/ludus/interpreter_new.clj +++ b/src/ludus/interpreter_new.clj @@ -5,13 +5,13 @@ [ludus.scanner :as s])) (def source - "spawn foo + "#{a as :number} " ) (def tokens (-> source s/scan :tokens)) -(def result (p/apply-parser g/spawn tokens)) +(def result (p/apply-parser g/dict-pattern tokens)) (-> result :data) From 3bd34f12694a3d9f7ad80c9d23f0dfb738714578 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Wed, 31 May 2023 11:42:51 -0400 Subject: [PATCH 34/43] Fix type member of prelude --- src/ludus/prelude.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ludus/prelude.clj b/src/ludus/prelude.clj index a4f7238..26aea38 100644 --- a/src/ludus/prelude.clj +++ b/src/ludus/prelude.clj @@ -158,5 +158,5 @@ "conj" conj- "get" get- "draw" draw - "type" type + "type" type- }) \ No newline at end of file From 82a539a1122f10c8ed3ca99d2e6a1c7cf337b499 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Wed, 31 May 2023 11:51:02 -0400 Subject: [PATCH 35/43] Update struct match --- src/ludus/interpreter.clj | 83 +++++++++++++++++++++++++-------------- 1 file changed, 54 insertions(+), 29 deletions(-) diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index d09ac97..4009070 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -170,7 +170,6 @@ (let [ctx-diff (volatile! @ctx-vol) splat? (= :splattern (-> members peek :type)) length (count kws)] - (if splat? (println "Pattern has splat!!")) (loop [i 0] (cond (> length i) @@ -193,11 +192,9 @@ (let [splat (-> members peek) splat-data (-> splat :data first) splat-type (-> splat-data :type)] - (println "!!!!Matching splat") (if (= :word splat-type) - (let [unmatched (apply dissoc dict kws) + (let [unmatched (assoc (apply dissoc dict kws) ::data/dict true) match? (match splat-data unmatched ctx-diff)] - (println "Splatting " unmatched "\ninto " ) (if (:success match?) {:success true :ctx (merge @ctx-diff (:ctx match?))} {:success false @@ -211,31 +208,59 @@ )))))) -;; TODO: update this to use new AST representation -(defn- match-struct [pattern value ctx-vol] - (cond - (not (map? value)) - {:success false :reason "Could not match non-struct value to struct pattern"} +(defn- match-struct [pattern dict ctx-vol] + (let [members (:data pattern) + pattern-map (pattern-to-map pattern) + kws (keys pattern-map)] + (cond + (not (map? dict)) + {:success false :reason "Could not match non-struct value to struct pattern"} + + (not (::data/dict dict)) + {:success false :reason "Cannot match non-struct value to struct pattern"} - (not (::data/struct value)) - {:success false :reason "Cannot match non-struct data types a struct pattern"} + (empty? members) + {:success true :ctx {}} + + :else + (let [ctx-diff (volatile! @ctx-vol) + splat? (= :splattern (-> members peek :type)) + length (count kws)] + (loop [i 0] + (cond + (> length i) + (let [kw (nth kws i) + pattern-at (kw pattern-map) + value (kw dict)] + (if (contains? dict kw) + (let [match? (match pattern-at value ctx-diff)] + (if (:success match?) + (do + (vswap! ctx-diff #(merge % (:ctx match?))) + (recur (inc i))) + {:success false + :reason (str "Could not match " pattern " with value " dict " at key " kw " because " (:reason match?))} + )) + {:success false + :reason (str "Could not match " pattern " with " dict " at key " kw " because there is no value at " kw)})) - :else - (let [members (:members pattern) - kws (keys members) - ctx-diff (volatile! @ctx-vol)] - (loop [i (dec (count kws))] - (if (> 0 i) - {:success true :ctx @ctx-diff} - (let [kw (nth kws i)] - (if (contains? value kw) - (let [match? (match (kw members) (kw value) ctx-diff)] - (if (:success match?) - (do - (vswap! ctx-diff #(merge % (:ctx match?))) - (recur (dec i))) - {:success false :reason (str "Could not match " pattern " with " value " at key " kw " because " (:reason match?))})) - {:success false :reason (str "Could not match " pattern " with " value " at key " kw ", because there is no value at " kw)}))))))) + splat? + (let [splat (-> members peek) + splat-data (-> splat :data first) + splat-type (-> splat-data :type)] + (if (= :word splat-type) + (let [unmatched (assoc (apply dissoc dict kws) ::data/dict true) + match? (match splat-data unmatched ctx-diff)] + (if (:success match?) + {:success true :ctx (merge @ctx-diff (:ctx match?))} + {:success false + :reason (str "Could not match " pattern " with value " dict " because " (:reason match?))} + )) + {:success true :ctx @ctx-diff} + )) + + :else + {:success true :ctx @ctx-diff})))))) (defn- match-typed [pattern value ctx] (let [data (:data pattern) @@ -936,8 +961,8 @@ (do (def source " - let #{a as :number} = #{:a 1} - a + let #{...x} = #{:a 1} + x ") (println "") From 67e230c71466ca595b913b7d2581c367010f1110 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Wed, 31 May 2023 11:51:43 -0400 Subject: [PATCH 36/43] Actually save work --- TODO.xit | 10 +++++----- src/ludus/grammar.clj | 2 +- src/ludus/interpreter.clj | 8 ++++---- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/TODO.xit b/TODO.xit index 15c3284..114eed8 100644 --- a/TODO.xit +++ b/TODO.xit @@ -2,11 +2,11 @@ [x] Fix recursive definition problems in grammar.clj TODOS from interpreter -[ ] implement tuple splat patterns -[ ] update match-list to use new AST representation -[ ] fix length comparison when pattern includes splats -[ ] update match-dict to use new AST representation -[ ] update match-struct to use new AST representation +[x] implement tuple splat patterns +[x] update match-list to use new AST representation +[x] fix length comparison when pattern includes splats +[x] update match-dict to use new AST representation +[x] update match-struct to use new AST representation [ ] update interpret-receive to use new AST representation [ ] Check interpret-fn-inner ctx for cycles/bugs diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 97634e8..644c71d 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -49,7 +49,7 @@ (defp typed group weak-order [:word (quiet :as) :keyword]) -(defp dict-pattern-term flat choice [pair-pattern :word typed splattern]) +(defp dict-pattern-term flat choice [pair-pattern typed :word splattern]) (defp dict-pattern-entry weak-order [dict-pattern-term separators]) diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index 4009070..0ff06d1 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -193,7 +193,7 @@ splat-data (-> splat :data first) splat-type (-> splat-data :type)] (if (= :word splat-type) - (let [unmatched (assoc (apply dissoc dict kws) ::data/dict true) + (let [unmatched (apply dissoc dict kws) match? (match splat-data unmatched ctx-diff)] (if (:success match?) {:success true :ctx (merge @ctx-diff (:ctx match?))} @@ -216,7 +216,7 @@ (not (map? dict)) {:success false :reason "Could not match non-struct value to struct pattern"} - (not (::data/dict dict)) + (not (::data/struct dict)) {:success false :reason "Cannot match non-struct value to struct pattern"} (empty? members) @@ -249,7 +249,7 @@ splat-data (-> splat :data first) splat-type (-> splat-data :type)] (if (= :word splat-type) - (let [unmatched (assoc (apply dissoc dict kws) ::data/dict true) + (let [unmatched (assoc (apply dissoc dict ::data/struct kws) ::data/dict true) match? (match splat-data unmatched ctx-diff)] (if (:success match?) {:success true :ctx (merge @ctx-diff (:ctx match?))} @@ -961,7 +961,7 @@ (do (def source " - let #{...x} = #{:a 1} + let @{...x} = @{:a 1, :b 2, :c 3} x ") From c8c74fbd49fdfc65e3f7204e12dcbf4d058769e1 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Wed, 31 May 2023 11:18:55 -0600 Subject: [PATCH 37/43] Simplify conditional forms: when, if, etc. --- TODO.xit | 4 +-- src/ludus/grammar.clj | 51 ++++++++++++++++++++--------------- src/ludus/interpreter.clj | 11 +++++--- src/ludus/interpreter_new.clj | 4 +-- src/ludus/scanner.clj | 7 ++--- 5 files changed, 45 insertions(+), 32 deletions(-) diff --git a/TODO.xit b/TODO.xit index 114eed8..5b5d164 100644 --- a/TODO.xit +++ b/TODO.xit @@ -21,7 +21,7 @@ Finish interpreter [ ] Merge new interpreter Write a compiler: desugaring -[ ] `...` to `..._` in tuple & list patterns +[~] `...` to `..._` in tuple & list patterns [ ] placeholder partial application to anonymous lambda [ ] word -> :[word] word in pairs (patterns & expressions) @@ -31,10 +31,10 @@ Write a compiler: correctness [ ] check that recur is in tail position [ ] check that recur is only called inside loop or fn forms [ ] check ns accesses +[ ] prevent import cycles [ ] splattern is last member in a pattern [ ] -----List/Tuple [ ] -----Dict/Struct/Set -[ ] prevent import cycles Write a compiler: optimization [ ] devise tail call optimization diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj index 644c71d..52a6cd9 100644 --- a/src/ludus/grammar.clj +++ b/src/ludus/grammar.clj @@ -4,35 +4,25 @@ (declare expression pattern) -;(def separator (choice :separator [:comma :newline :break])) (defp separator choice [:comma :newline :break]) -;(def separators (quiet (one+ separator))) (defp separators quiet one+ separator) -;(def terminator (choice :terminator [:newline :semicolon :break])) (defp terminator choice [:newline :semicolon :break]) -;(def terminators (quiet (one+ terminator))) (defp terminators quiet one+ terminator) -;(def nls? (quiet (zero+ :nls :newline))) (defp nls? quiet zero+ :newline) -;(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) (maybe (flat (choice :splatted [:word :ignored :placeholder])))]))) (defp patt-splat-able 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]))) (defp literal flat choice [:nil :true :false :number :string]) -;(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])) (defp tuple-pattern-entry weak-order [tuple-pattern-term separators]) (defp tuple-pattern group order-1 [(quiet :lparen) @@ -65,29 +55,30 @@ (quiet :rbrace) ]) -(defp guard order-0 [(quiet :when) expression]) +(defp guard order-0 [(quiet :if) expression]) (defp pattern flat choice [literal :ignored :placeholder typed :word - :keyword + :keyword + :else tuple-pattern dict-pattern struct-pattern list-pattern]) -(defp match-clause group weak-order :match-clause [pattern (maybe guard) (quiet :rarrow) expression]) +(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) expression nls? - (quiet :with) (quiet :lbrace) - (quiet (zero+ terminator)) - (one+ match-entry) - (quiet :rbrace) - ]) +(defp match-old group order-1 [(quiet :match) expression nls? + (quiet :with) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ match-entry) + (quiet :rbrace) + ]) (defp if-expr group order-1 [(quiet :if) nls? @@ -105,11 +96,26 @@ (defp cond-entry weak-order [cond-clause terminators]) -(defp cond-expr group order-1 [(quiet :cond) (quiet :lbrace) +(defp cond-old group order-1 [(quiet :cond) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ cond-entry) + (quiet :rbrace)]) + +(defp match group order-1 [expression nls? + (quiet :is) (quiet :lbrace) + (quiet (zero+ terminator)) + (one+ match-entry) + (quiet :rbrace)]) + +(defp cond-expr group order-1 [(quiet :lbrace) (quiet (zero+ terminator)) (one+ cond-entry) (quiet :rbrace)]) +(defp when-tail flat choice [match cond-expr]) + +(defp when-expr weak-order [(quiet :when) when-tail]) + (defp let-expr group order-1 [(quiet :let) pattern (quiet :equals) @@ -229,11 +235,12 @@ (flat (choice :loop-body [fn-clause compound-loop]))]) (defp expression flat choice [fn-expr - match + ;match loop-expr let-expr if-expr - cond-expr + ;cond-expr + when-expr spawn receive synthetic diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index 0ff06d1..4ccdfc9 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -275,7 +275,7 @@ ;(println "Matching " value " with pattern type " (:type pattern)) (let [ctx @ctx-vol] (case (:type pattern) - (:placeholder :ignored) + (:placeholder :ignored :else) {:success true :ctx {}} (:number :nil :true :false :string :keyword) @@ -843,6 +843,8 @@ :ref-expr (interpret-ref ast ctx) + :when-expr (interpret-ast (-> ast :data first) ctx) + ; ::ast/spawn (interpret-spawn ast ctx) ; ::ast/receive (interpret-receive ast ctx) @@ -961,8 +963,11 @@ (do (def source " - let @{...x} = @{:a 1, :b 2, :c 3} - x + let x = (1, 2) + when x is { + (y, 2) if eq (y, 1) -> :onetwo + _ -> :not_x + } ") (println "") diff --git a/src/ludus/interpreter_new.clj b/src/ludus/interpreter_new.clj index 3c7c268..2a5815e 100644 --- a/src/ludus/interpreter_new.clj +++ b/src/ludus/interpreter_new.clj @@ -5,13 +5,13 @@ [ludus.scanner :as s])) (def source - "#{a as :number} + "when x is { true -> true } " ) (def tokens (-> source s/scan :tokens)) -(def result (p/apply-parser g/dict-pattern tokens)) +(def result (p/apply-parser g/when-expr tokens)) (-> result :data) diff --git a/src/ludus/scanner.clj b/src/ludus/scanner.clj index a4c5ea8..368da41 100644 --- a/src/ludus/scanner.clj +++ b/src/ludus/scanner.clj @@ -8,7 +8,7 @@ "List of Ludus reserved words." ;; see ludus-spec repo for more info {"as" :as ;; impl for `import`; not yet for patterns - "cond" :cond ;; impl + ;"cond" :cond ;; impl "do" :do ;; impl "else" :else ;; impl "false" :false ;; impl -> literal word @@ -17,7 +17,7 @@ "import" :import ;; impl "let" :let ;; impl "loop" :loop ;; impl - "match" :match ;; impl + ; "match" :match ;; impl "nil" :nil ;; impl -> literal word "ns" :ns ;; impl ;; "panic!" :panic ;; impl (should be a function) @@ -25,7 +25,7 @@ "ref" :ref ;; impl "then" :then ;; impl "true" :true ;; impl -> literal word - "with" :with ;; impl + ;"with" :with ;; impl ;; actor model/concurrency "receive" :receive @@ -40,6 +40,7 @@ "test" :test "when" :when ;; "module" :module ;; not necessary if we don't have datatypes + "is" :is }) (def literal-words { From a6ef6522c0c5e8ea3a2b8b661859428af6992484 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Thu, 1 Jun 2023 12:46:52 -0600 Subject: [PATCH 38/43] Add `clj` fn to prelude, calls arbitrary Clojure. --- src/ludus/interpreter.clj | 20 +------------------- src/ludus/prelude.clj | 13 +++++++++++++ 2 files changed, 14 insertions(+), 19 deletions(-) diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index 4ccdfc9..4bca9da 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -963,11 +963,7 @@ (do (def source " - let x = (1, 2) - when x is { - (y, 2) if eq (y, 1) -> :onetwo - _ -> :not_x - } + ") (println "") @@ -985,17 +981,3 @@ (println result) result)) -(comment " - - Left to do: - * improve panics - * add location info for panics - * refactor calling keywords - * refactor accessing structs vs. hashes - - ") - - - - - diff --git a/src/ludus/prelude.clj b/src/ludus/prelude.clj index 26aea38..bf10de1 100644 --- a/src/ludus/prelude.clj +++ b/src/ludus/prelude.clj @@ -135,6 +135,18 @@ ::data/type ::data/clj :body get-type}) +(defn strpart [kw] (->> kw str rest (apply str))) + +(def clj {:name "clj" + ::data/type ::data/clj + :body (fn [& args] + (println "Args passed: " args) + (let [called (-> args first strpart read-string eval) + fn-args (rest args)] + (println "Fn: " called) + (println "Args: " fn-args) + (apply called fn-args)))}) + (def prelude { "id" id "foo" :foo @@ -159,4 +171,5 @@ "get" get- "draw" draw "type" type- + "clj" clj }) \ No newline at end of file From c17932571945021ddc57794609add1920f78636e Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Thu, 1 Jun 2023 13:11:06 -0600 Subject: [PATCH 39/43] Improve prelude --- src/ludus/interpreter.clj | 4 +++- src/ludus/prelude.clj | 31 ++++++++++++++++++++++++++++--- 2 files changed, 31 insertions(+), 4 deletions(-) diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index 4bca9da..cf2ac8c 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -963,7 +963,9 @@ (do (def source " - + let xs = [1, 2, 3] + let ys = #{:a 1, :b 2} + get (:c, ys) ") (println "") diff --git a/src/ludus/prelude.clj b/src/ludus/prelude.clj index bf10de1..b21d07f 100644 --- a/src/ludus/prelude.clj +++ b/src/ludus/prelude.clj @@ -92,12 +92,36 @@ (def get- {:name "get" ::data/type ::data/clj - :body get}) + :body (fn + ([key, map] + (if (map? map) + (get map key) + nil)) + ([key, map, default] + (if (map? map) + (get map key default) + default)))}) (def draw {:name "draw" ::data/type ::data/clj :body d/ludus-draw}) +(def first- {:name "first" + ::data/type ::data/clj + :body (fn [v] (second v))}) + +(def rest- {:name "rest" + ::data/type ::data/clj + :body (fn [v] + (into [::data/list] (nthrest v 2)))}) + +(def nth- {:name "nth" + ::data/type ::data/clj + :body (fn [i, xs] + (if (contains? xs (inc i)) + (nth xs (inc i)) + nil))}) + (defn get-type [value] (let [t (type value)] (cond @@ -149,8 +173,6 @@ (def prelude { "id" id - "foo" :foo - "bar" :bar "eq" eq "add" add "print" print- @@ -172,4 +194,7 @@ "draw" draw "type" type- "clj" clj + "first" first- + "rest" rest- + "nth" nth- }) \ No newline at end of file From 7c30b6259bb29d2dcca4378563d766f4ffbe570c Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Thu, 1 Jun 2023 15:06:33 -0600 Subject: [PATCH 40/43] Wire up repl & file interpreters. --- foo.ld | 1 + sandbox.ld | 3 ++ src/ludus/core.clj | 32 ++++++++++--------- src/ludus/interpreter.clj | 66 +++++++++++++++++++++++---------------- src/ludus/prelude.clj | 8 ++--- src/ludus/repl.clj | 42 +++++++++++++++---------- 6 files changed, 88 insertions(+), 64 deletions(-) create mode 100644 foo.ld create mode 100644 sandbox.ld diff --git a/foo.ld b/foo.ld new file mode 100644 index 0000000..2a2d08c --- /dev/null +++ b/foo.ld @@ -0,0 +1 @@ +:foo \ No newline at end of file diff --git a/sandbox.ld b/sandbox.ld new file mode 100644 index 0000000..b168e9b --- /dev/null +++ b/sandbox.ld @@ -0,0 +1,3 @@ +import "foo.ld" as foo + +print ("Hello, world!", foo) \ No newline at end of file diff --git a/src/ludus/core.clj b/src/ludus/core.clj index 5ebf00c..dc65914 100644 --- a/src/ludus/core.clj +++ b/src/ludus/core.clj @@ -1,37 +1,39 @@ (ns ludus.core "A tree-walk interpreter for the Ludus language." (:require - [ludus.scanner :as scanner] - [ludus.parser :as parser] - [ludus.interpreter :as interpreter] - [ludus.show :as show] - [clojure.pprint :as pp] - [ludus.loader :as loader] - [ludus.repl :as repl]) + [ludus.scanner :as scanner] + ;[ludus.parser :as parser] + [ludus.parser-new :as p] + [ludus.grammar :as g] + [ludus.interpreter :as interpreter] + [ludus.show :as show] + [clojure.pprint :as pp] + [ludus.loader :as loader] + [ludus.repl :as repl]) (:gen-class)) (defn- run [file source] -(comment (let [scanned (scanner/scan source)] + (let [scanned (scanner/scan source)] (if (not-empty (:errors scanned)) (do (println "I found some scanning errors!") (pp/pprint (:errors scanned)) (System/exit 65)) - (let [parsed (parser/parse scanned)] - (if (not-empty (:errors parsed)) + (let [parsed (p/apply-parser g/script (:tokens scanned))] + (if (p/fail? parsed) (do (println "I found some parsing errors!") - (pp/pprint (:errors parsed)) + (println p/err-msg parsed) (System/exit 66)) - (let [interpreted (interpreter/interpret parsed file)] + (let [interpreted (interpreter/interpret source file parsed)] (println (show/show interpreted)) - (System/exit 0)))))))) + (System/exit 0))))))) (defn -main [& args] -(comment (cond + (cond (= (count args) 1) (let [file (first args) source (loader/load-import file)] (run file source)) - :else (repl/launch)))) \ No newline at end of file + :else (repl/launch))) \ No newline at end of file diff --git a/src/ludus/interpreter.clj b/src/ludus/interpreter.clj index cf2ac8c..e06a80d 100644 --- a/src/ludus/interpreter.clj +++ b/src/ludus/interpreter.clj @@ -11,8 +11,8 @@ [ludus.loader :as loader] [ludus.token :as token] [ludus.process :as process] - [clojure.pprint :as pp] - [clojure.set])) + [clojure.set] + [clojure.string])) (def ^:dynamic self @process/current-pid) @@ -301,7 +301,7 @@ :struct-pattern (match-struct pattern value ctx-vol) - (throw (ex-info "Unknown pattern on line " {:pattern pattern :value value}))))) + (throw (ex-info "Unknown pattern on line " {:ast pattern :value value}))))) (defn- update-ctx [ctx new-ctx] (merge ctx new-ctx)) @@ -607,9 +607,15 @@ (if (::loader/error (ex-data e)) (throw (ex-info (ex-message e) {:ast ast})) (throw e)))) - result (-> source (scanner/scan) (parser/parse) (interpret-file path))] - (vswap! ctx update-ctx {name result}) - result + parsed (->> source (scanner/scan) :tokens (p/apply-parser g/script))] + (if (p/fail? parsed) + (throw (ex-info + (str "Parse error in file " path "\n" + (p/err-msg parsed)) + {:ast ast})) + (let [interpret-result (interpret-file source path parsed)] + (vswap! ctx update-ctx {name interpret-result}) + interpret-result)) )))) (defn- interpret-ref [ast ctx] @@ -883,35 +889,42 @@ :dict (interpret-dict ast ctx) :struct-literal - (let [members (:members ast)] (interpret-struct ast ctx)) + (interpret-struct ast ctx) - (throw (ex-info "Unknown AST node type" {:ast ast})))) + (throw (ex-info (str "Unknown AST node type: " (:type ast)) {:ast ast})))) + +(defn get-line [source line] + (if line + (let [lines (clojure.string/split source #"\n")] + (clojure.string/trim (nth lines (dec line)))))) ;; TODO: update this to use new parser pipeline & new AST representation -(defn interpret-file [parsed file] +(defn interpret-file [source path parsed] (try - (let [base-ctx (volatile! (merge {:file file} prelude/prelude process/process))] - (interpret-ast (::parser/ast parsed) base-ctx)) + (let [base-ctx (volatile! {::parent (volatile! prelude/prelude) :file path})] + (interpret-ast parsed base-ctx)) (catch clojure.lang.ExceptionInfo e - (println "Ludus panicked in" file) - (println "On line" (get-in (ex-data e) [:ast :token ::token/line])) + (println "Ludus panicked in" path) + (println "On line" (get-in (ex-data e) [:ast :token :line])) + (println ">>> " (get-line source (get-in (ex-data e) [:ast :token :line]))) (println (ex-message e)) (System/exit 67)))) ;; TODO: update this to use new parser pipeline & new AST representation -(defn interpret [parsed file] +(defn interpret [source path parsed] (try - (let [base-ctx (volatile! (merge {:file file} prelude/prelude process/process)) + (let [base-ctx (volatile! {::parent (volatile! prelude/prelude) :file path}) process (process/new-process)] (process/start-vm) (with-bindings {#'self (:pid @process)} - (let [result (interpret-ast (::parser/ast parsed) {::parent base-ctx})] + (let [result (interpret-ast parsed base-ctx)] (swap! process #(assoc % :status :dead)) (process/stop-vm) result))) (catch clojure.lang.ExceptionInfo e - (println "Ludus panicked in" file) - (println "On line" (get-in (ex-data e) [:ast :token ::token/line])) + (println "Ludus panicked in" path) + (println "On line" (get-in (ex-data e) [:ast :token :line])) + (println ">>> " (get-line source (get-in (ex-data e) [:ast :token :line]))) (println (ex-message e)) (System/exit 67)))) @@ -927,10 +940,11 @@ result))) (catch clojure.lang.ExceptionInfo e (process/stop-vm) - (println "Ludus panicked!") - (println "On line" (get-in (ex-data e) [:ast :token :line])) + (println "Ludus panicked on line " (get-in (ex-data e) [:ast :token :line])) + (println "> " (get-in (ex-data e) [:ast :token])) (println (ex-message e)) - (pp/pprint (ex-data e))))) + ;(pp/pprint (ex-data e)) + ))) ;; TODO: update this to use new parser pipeline & new AST representation (defn interpret-repl @@ -941,7 +955,7 @@ (try (process/start-vm) (with-bindings {#'self pid} - (let [result (interpret-ast (::parser/ast parsed) ctx)] + (let [result (interpret-ast parsed ctx)] {:result result :ctx ctx :pid pid})) (catch clojure.lang.ExceptionInfo e (println "Ludus panicked!") @@ -952,7 +966,7 @@ (try (process/start-vm) (with-bindings {#'self pid} - (let [result (interpret-ast (::parser/ast parsed) ctx)] + (let [result (interpret-ast parsed ctx)] {:result result :ctx ctx :pid pid})) (catch clojure.lang.ExceptionInfo e (println "Ludus panicked!") @@ -961,11 +975,9 @@ ))))) -(do +(comment (def source " - let xs = [1, 2, 3] - let ys = #{:a 1, :b 2} - get (:c, ys) + let 2 = 1 ") (println "") diff --git a/src/ludus/prelude.clj b/src/ludus/prelude.clj index b21d07f..d4f8337 100644 --- a/src/ludus/prelude.clj +++ b/src/ludus/prelude.clj @@ -2,7 +2,8 @@ (:require [ludus.data :as data] [ludus.show :as show] - [ludus.draw :as d])) + ;[ludus.draw :as d] + )) ;; TODO: make eq, and, or special forms that short-circuit ;; Right now, they evaluate all their args @@ -102,10 +103,6 @@ (get map key default) default)))}) -(def draw {:name "draw" - ::data/type ::data/clj - :body d/ludus-draw}) - (def first- {:name "first" ::data/type ::data/clj :body (fn [v] (second v))}) @@ -191,7 +188,6 @@ "assoc" assoc- "conj" conj- "get" get- - "draw" draw "type" type- "clj" clj "first" first- diff --git a/src/ludus/repl.clj b/src/ludus/repl.clj index 6b5fcd1..6455f48 100644 --- a/src/ludus/repl.clj +++ b/src/ludus/repl.clj @@ -1,12 +1,15 @@ (ns ludus.repl (:require [ludus.scanner :as scanner] - [ludus.parser :as parser] + ;[ludus.parser :as parser] + [ludus.parser-new :as p] + [ludus.grammar :as g] [ludus.interpreter :as interpreter] [ludus.prelude :as prelude] [ludus.show :as show] [ludus.data :as data] - [ludus.process :as process])) + ;[ludus.process :as process] + )) (declare repl-prelude new-session) @@ -20,7 +23,7 @@ (println "\nGoodbye!") (System/exit 0)) -(def base-ctx (merge prelude/prelude process/process +(def base-ctx (merge prelude/prelude ;process/process {::repl true "repl" {::data/struct true @@ -91,20 +94,27 @@ (= "" input) (recur) :else - (let [parsed (-> input (scanner/scan) (parser/parse)) - {result :result ctx :ctx pid- :pid} - (if pid - (interpreter/interpret-repl parsed orig-ctx pid) - (interpreter/interpret-repl parsed orig-ctx))] - (if (= result ::interpreter/error) - (recur) + (let [parsed (->> input + (scanner/scan) + :tokens + (p/apply-parser g/script))] + (if (= :err (:status parsed)) (do - (println (show/show result)) - (when (not (= @ctx @orig-ctx)) - (swap! session-atom #(assoc % :ctx ctx))) - (when (not (= pid pid-)) - (swap! session-atom #(assoc % :pid pid-))) - (recur)))))))) + (println (p/err-msg parsed)) + (recur)) + (let [{result :result ctx :ctx pid- :pid} + (if pid + (interpreter/interpret-repl parsed orig-ctx pid) + (interpreter/interpret-repl parsed orig-ctx))] + (if (= result :error) + (recur) + (do + (println (show/show result)) + (when (not (= @ctx @orig-ctx)) + (swap! session-atom #(assoc % :ctx ctx))) + (when (not (= pid pid-)) + (swap! session-atom #(assoc % :pid pid-))) + (recur)))))))))) (defn launch [] (println "Welcome to Ludus (v. 0.1.0-alpha)") From 5c8ba725a9107d73ae873b0391de720f08dd1966 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Thu, 1 Jun 2023 17:27:55 -0600 Subject: [PATCH 41/43] Bugfixes. --- sandbox.ld | 48 +++++++++++++++++++++++++++++++++-- src/ludus/core.clj | 2 +- src/ludus/interpreter_new.clj | 6 ++--- src/ludus/prelude.clj | 40 ++++++++++++++++++++++++++--- src/ludus/scanner.clj | 2 +- 5 files changed, 87 insertions(+), 11 deletions(-) diff --git a/sandbox.ld b/sandbox.ld index b168e9b..23bce84 100644 --- a/sandbox.ld +++ b/sandbox.ld @@ -1,3 +1,47 @@ -import "foo.ld" as foo +fn map { + (f) -> fn mapper (xs) -> map (f, xs) + (f, xs) -> { + let n = count (xs) + loop (0, []) with (i, ys) -> if eq (i, n) + then ys + else recur (inc (i), conj (ys, f (nth (i, xs)))) + } +} -print ("Hello, world!", foo) \ No newline at end of file +fn reduce { + (f) -> fn reducer { + (xs) -> reduce (f, xs) + (xs, init) -> reduce (f, xs, init) + } + (f, xs) -> { + let first_x = first (xs) + let more_xs = rest (xs) + reduce (f, more_xs, first_x) + } + (f, xs, init) -> { + let n = count (xs) + loop (0, init) with (i, acc) -> if eq (i, n) + then acc + else { + let curr = nth (i, xs) + let next = f (acc, curr) + recur (inc (i), next) + } + } +} + +fn filter { + (f) -> fn filterer (xs) -> filter (f, xs) + (f, xs) -> { + let n = count (xs) + loop (0, []) with (i, ys) -> when { + eq (i, n) -> ys + f (nth (i, xs)) -> recur (inc (i), conj (ys, nth (i, xs))) + else -> recur (inc (i), ys) + } + } +} + +let xs = [1, 2, 3] + +filter (gte (_, 2) ,xs) \ No newline at end of file diff --git a/src/ludus/core.clj b/src/ludus/core.clj index dc65914..e1296e3 100644 --- a/src/ludus/core.clj +++ b/src/ludus/core.clj @@ -23,7 +23,7 @@ (if (p/fail? parsed) (do (println "I found some parsing errors!") - (println p/err-msg parsed) + (println (p/err-msg parsed)) (System/exit 66)) (let [interpreted (interpreter/interpret source file parsed)] (println (show/show interpreted)) diff --git a/src/ludus/interpreter_new.clj b/src/ludus/interpreter_new.clj index 2a5815e..cba232c 100644 --- a/src/ludus/interpreter_new.clj +++ b/src/ludus/interpreter_new.clj @@ -5,13 +5,13 @@ [ludus.scanner :as s])) (def source - "when x is { true -> true } + "(1 2) " ) (def tokens (-> source s/scan :tokens)) -(def result (p/apply-parser g/when-expr tokens)) +(def result (p/apply-parser g/script tokens)) (-> result :data) @@ -24,7 +24,7 @@ (-> node (report) (dissoc - :status + ;:status :remaining :token) (update :data #(into [] (map clean) %))) diff --git a/src/ludus/prelude.clj b/src/ludus/prelude.clj index d4f8337..673e3cf 100644 --- a/src/ludus/prelude.clj +++ b/src/ludus/prelude.clj @@ -37,6 +37,22 @@ ::data/type ::data/clj :body /}) +(def gt {:name "gt" + ::data/type ::data/clj + :body >}) + +(def gte {:name "gte" + ::data/type ::data/clj + :body >=}) + +(def lt {:name "lt" + ::data/type ::data/clj + :body <}) + +(def lte {:name "lte" + ::data/type ::data/clj + :body <=}) + (def inc- {:name "inc" ::data/type ::data/clj :body inc}) @@ -114,10 +130,17 @@ (def nth- {:name "nth" ::data/type ::data/clj - :body (fn [i, xs] - (if (contains? xs (inc i)) - (nth xs (inc i)) - nil))}) + :body (fn + ([i, xs] + (cond + (> 0 i) nil + (contains? xs (inc i)) (nth xs (inc i)) + :else nil)) + ([i, xs, default] + (cond + (> 0 i) default + (contains? xs (inc i)) (nth xs (inc i)) + :else default)))}) (defn get-type [value] (let [t (type value)] @@ -168,6 +191,10 @@ (println "Args: " fn-args) (apply called fn-args)))}) +(def count- {:name "count" + ::data/type ::data/clj + :body (fn [xs] (dec (count xs)))}) + (def prelude { "id" id "eq" eq @@ -176,6 +203,10 @@ "sub" sub "mult" mult "div" div + "gt" gt + "gte" gte + "lt" lt + "lte" lte "inc" inc- "dec" dec- "not" not @@ -193,4 +224,5 @@ "first" first- "rest" rest- "nth" nth- + "count" count- }) \ No newline at end of file diff --git a/src/ludus/scanner.clj b/src/ludus/scanner.clj index 368da41..bc2ac78 100644 --- a/src/ludus/scanner.clj +++ b/src/ludus/scanner.clj @@ -25,7 +25,7 @@ "ref" :ref ;; impl "then" :then ;; impl "true" :true ;; impl -> literal word - ;"with" :with ;; impl + "with" :with ;; impl ;; actor model/concurrency "receive" :receive From d6981b37144aa9bc9209a34d5020b82858bd7572 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Fri, 2 Jun 2023 16:03:40 -0600 Subject: [PATCH 42/43] Update TODOs --- TODO.xit | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/TODO.xit b/TODO.xit index 5b5d164..2a890d9 100644 --- a/TODO.xit +++ b/TODO.xit @@ -1,6 +1,11 @@ [x] Fix recursive definition problems in grammar.clj +TODOS for parser +[ ] Make parser errors pretty +[ ] Use synchronization to make parsing more robust +[ ] Decide on synchronization tokens: [then else ] ) } , ; \n] + TODOS from interpreter [x] implement tuple splat patterns [x] update match-list to use new AST representation From 7d2a7061e8e3f12e4bed2dac93fc6dd558c51801 Mon Sep 17 00:00:00 2001 From: Scott Richmond Date: Fri, 2 Jun 2023 16:04:03 -0600 Subject: [PATCH 43/43] Futz --- sandbox.ld | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/sandbox.ld b/sandbox.ld index 23bce84..468c891 100644 --- a/sandbox.ld +++ b/sandbox.ld @@ -42,6 +42,8 @@ fn filter { } } +let greater_than_two = gt (_, 2) + let xs = [1, 2, 3] -filter (gte (_, 2) ,xs) \ No newline at end of file +filter (greater_than_two ,xs) \ No newline at end of file