diff --git a/TODO.xit b/TODO.xit new file mode 100644 index 0000000..2a890d9 --- /dev/null +++ b/TODO.xit @@ -0,0 +1,49 @@ + +[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 +[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 + +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 + +Finish interpreter +[ ] Wire up new interpreter to repl, script situation +[ ] 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 +[ ] prevent import cycles +[ ] splattern is last member in a pattern +[ ] -----List/Tuple +[ ] -----Dict/Struct/Set + +Write a compiler: optimization +[ ] devise tail call optimization + +Next steps +[ ] Get drawing working? +[ ] Add stack traces for panics 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 index 7cdc4ee..2b2c057 100644 --- a/sandbox.ld +++ b/sandbox.ld @@ -26,4 +26,54 @@ let baz = do 69 > default (12) > print (:baz, _) let quux = do nil > default (12) > print (:quux, _) -unwrap ((:err, "message")) +& unwrap ((:err, "message")) + +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)))) + } +} + +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 greater_than_two = gt (_, 2) + +let xs = [1, 2, 3] + +filter (greater_than_two ,xs) diff --git a/src/ludus/compile.clj b/src/ludus/compile.clj new file mode 100644 index 0000000..5ead91d --- /dev/null +++ b/src/ludus/compile.clj @@ -0,0 +1,35 @@ +(ns ludus.compile + (:require + [ludus.grammar :as g] + [ludus.parser-new :as p] + [ludus.scanner :as s])) + +(def source + "1" + ) + +(def result (->> source s/scan :tokens (p/apply-parser g/script))) + +(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 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) + - flag tail calls for optimization (optimization) + - direct tail calls + - through different expressions + - block + - if + - cond + - 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 diff --git a/src/ludus/core.clj b/src/ludus/core.clj index 72f4bbe..e1296e3 100644 --- a/src/ludus/core.clj +++ b/src/ludus/core.clj @@ -1,13 +1,15 @@ (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] @@ -17,13 +19,13 @@ (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))))))) diff --git a/src/ludus/grammar.clj b/src/ludus/grammar.clj new file mode 100644 index 0000000..52a6cd9 --- /dev/null +++ b/src/ludus/grammar.clj @@ -0,0 +1,318 @@ +(ns ludus.grammar + (:require [ludus.parser-new :refer :all] + [ludus.scanner :as scan])) + +(declare expression pattern) + +(defp separator choice [:comma :newline :break]) + +(defp separators quiet one+ separator) + +(defp terminator choice [:newline :semicolon :break]) + +(defp terminators quiet one+ terminator) + +(defp nls? quiet zero+ :newline) + +(defp splat group order-1 [(quiet :splat) :word]) + +(defp patt-splat-able flat choice [:word :ignored :placeholder]) +(defp splattern group order-1 [(quiet :splat) (maybe patt-splat-able)]) + +(defp literal flat choice [:nil :true :false :number :string]) + +(defp tuple-pattern-term flat choice [pattern splattern]) + +(defp tuple-pattern-entry weak-order [tuple-pattern-term separators]) + +(defp tuple-pattern group order-1 [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ tuple-pattern-entry) + (quiet :rparen)]) + +(defp list-pattern group order-1 [(quiet :lbracket) + (quiet (zero+ separator)) + (zero+ tuple-pattern-entry) + (quiet :rbracket)]) + +(defp pair-pattern group weak-order [:keyword pattern]) + +(defp typed group weak-order [:word (quiet :as) :keyword]) + +(defp dict-pattern-term flat choice [pair-pattern typed :word splattern]) + +(defp dict-pattern-entry weak-order [dict-pattern-term separators]) + +(defp dict-pattern group order-1 [(quiet :startdict) + (quiet (zero+ separator)) + (zero+ dict-pattern-entry) + (quiet :rbrace) + ]) + +(defp struct-pattern group order-1 [(quiet :startstruct) + (quiet (zero+ separator)) + (zero+ dict-pattern-entry) + (quiet :rbrace) + ]) + +(defp guard order-0 [(quiet :if) expression]) + +(defp pattern flat choice [literal + :ignored + :placeholder + typed + :word + :keyword + :else + tuple-pattern + dict-pattern + struct-pattern + list-pattern]) + +(defp match-clause group weak-order [pattern (maybe guard) (quiet :rarrow) expression]) + +(defp match-entry weak-order [match-clause terminators]) + +(defp match-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? + expression + nls? + (quiet :then) + expression + nls? + (quiet :else) + expression]) + +(defp cond-lhs flat choice [expression :placeholder :else]) + +(defp cond-clause group weak-order [cond-lhs (quiet :rarrow) expression]) + +(defp cond-entry weak-order [cond-clause terminators]) + +(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) + nls? + expression]) + +(defp tuple-entry weak-order [expression separators]) + +(defp tuple group order-1 [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ tuple-entry) + (quiet :rparen)]) + +(defp list-term flat choice [splat expression]) + +(defp list-entry order-1 [list-term separators]) + +(defp list-literal group order-1 [(quiet :lbracket) + (quiet (zero+ separator)) + (zero+ list-entry) + (quiet :rbracket)]) + +(defp set-literal group order-1 [(quiet :startset) + (quiet (zero+ separator)) + (zero+ list-entry) + (quiet :rbrace)]) + +(defp pair group order-0 [:keyword expression]) + +(defp struct-term flat choice [:word pair]) + +(defp struct-entry order-1 [struct-term separators]) + +(defp struct-literal group order-1 [(quiet :startstruct) + (quiet (zero+ separator)) + (zero+ struct-entry) + (quiet :rbrace)]) + +(defp dict-term flat choice [splat :word pair]) + +(defp dict-entry order-1 [dict-term separators]) + +(defp dict group order-1 [(quiet :startdict) + (quiet (zero+ separator)) + (zero+ dict-entry) + (quiet :rbrace)]) + +(defp arg-expr flat choice [:placeholder expression]) + +(defp arg-entry weak-order [arg-expr separators]) + +(defp args group order-1 [(quiet :lparen) + (quiet (zero+ separator)) + (zero+ arg-entry) + (quiet :rparen)]) + +(defp recur-call group order-1 [(quiet :recur) tuple]) + +(defp synth-root flat choice [:keyword :word]) + +(defp synth-term flat choice [args :keyword]) + +(defp synthetic group order-1 [synth-root (zero+ synth-term)]) + +(defp fn-clause group order-1 [tuple-pattern (maybe guard) (quiet :rarrow) expression]) + +(defp fn-entry order-1 [fn-clause terminators]) + +(defp compound group order-1 [(quiet :lbrace) + nls? + (maybe :string) + (quiet (zero+ terminator)) + (one+ fn-entry) + (quiet :rbrace) + ]) + +(defp clauses flat choice [fn-clause compound]) + +(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 + when-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 + +(comment + + (def source + "if 1 then 2 else 3" + ) + + (def rule (literal)) + + (def tokens (-> source scan/scan :tokens)) + + (def result (apply-parser script tokens)) + + + (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..e06a80d 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] @@ -9,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) @@ -27,173 +29,287 @@ ::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) -;; 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)} ))))))) (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"} + + (= :splattern (:type (peek members))) + (match-splatted 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?))})))))))) +;; 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"} + 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: fix this with splats - (not (= (count (:members pattern)) (count value))) - {:success false :reason "Cannot match lists of different lengths"} +(defn- member->kv [map member] + (let [type (:type member) + data (:data member)] + (case type + :word + (assoc map (keyword (first data)) member) - (= 0 (count (:members pattern)) (count value)) {:success true :ctx {}} + :pair-pattern + (assoc map (-> data first :data first) (second data)) - :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)] + :typed + (assoc map (-> data first :data first keyword) member) + + 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 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"} + + (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 (dec i))) - {:success false :reason (str "Could not match " pattern " with " value " because " (:reason match?))}))))))) + (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)})) -(defn- match-dict [pattern value ctx-vol] - (cond - (not (map? value)) - {:success false :reason "Could not match non-dict value to dict pattern"} + splat? + (let [splat (-> members peek) + splat-data (-> splat :data first) + splat-type (-> splat-data :type)] + (if (= :word splat-type) + (let [unmatched (apply dissoc dict kws) + 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} + )) - (not (::data/dict value)) - {:success false :reason "Cannot match non-dict data types to a dict pattern"} + :else + {:success true :ctx @ctx-diff} - :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)}))))))) + )))))) -(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/struct 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 ::data/struct 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) + 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")} + :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 (::ast/type pattern) - ::ast/placeholder {:success true :ctx {}} + (case (:type pattern) + (:placeholder :ignored :else) + {: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-pattern (match-tuple pattern value ctx-vol) - ::ast/dict (match-dict pattern value ctx-vol) + :list-pattern (match-list pattern value ctx-vol) - ::ast/struct (match-struct pattern value ctx-vol) + :dict-pattern (match-dict pattern value ctx-vol) - (throw (ex-info "Unknown pattern on line " {:pattern pattern}))))) + :struct-pattern (match-struct pattern value ctx-vol) + + (throw (ex-info "Unknown pattern on line " {:ast pattern :value value}))))) (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,113 +319,164 @@ 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-expr) + (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) + guard (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 - (do - (vswap! new-ctx #(merge % clause-ctx)) - (interpret-ast body new-ctx)) + (if guard + (if (interpret-ast guard (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})))))) (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)))))))) -(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) + guard (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 guard + (if (do + ;(println "######### Testing guard") + ;(println "Context: " clause-ctx) + (interpret-ast guard vclause)) + (do + ;(println "passed guard") + (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) @@ -322,30 +489,48 @@ :else (throw (ex-info "I don't know how to call that" {:ast lfn})))) +(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 (::ast/type curr)] - (if (= type ::ast/atom) + (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 (: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 data 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))) + ;;(println "interpreting synthetic " ast) + (let [data (:data ast) + root (first data) + terms (rest data)] + ;(println "!!!!!!!!!Interpreting synthetic w/ root " (:data root)) + (if (seq terms) + (do + ;;(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) @@ -364,32 +549,54 @@ (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] (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) @@ -400,15 +607,21 @@ (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))] - ;; (pp/pprint @ctx) - (vswap! ctx update-ctx {name result}) - ;; (pp/pprint @ctx) - 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] - (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) @@ -418,52 +631,63 @@ 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) + 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 - (do - (vswap! new-ctx #(merge % clause-ctx)) - (interpret-ast body new-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)) + (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] - (throw (ex-info (show/show (interpret-ast (:expr ast) ctx)) {:ast ast}))) - (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 [::data/list] (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)] - (into [] (reduce (list-term ctx) [] members)))) + (let [members (:data ast)] + (into [::data/list] (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) @@ -471,26 +695,69 @@ (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)))) + +;; TODO: update this to use new AST representation (defn- interpret-receive [ast ctx] (let [process-atom (get @process/processes self) inbox (promise) @@ -519,6 +786,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) @@ -535,7 +803,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} @@ -548,59 +816,60 @@ (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-expr (interpret-let ast ctx) - ::ast/let (interpret-let ast ctx) + :if-expr (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-expr (interpret-cond ast ctx) - ::ast/fn (interpret-fn ast ctx) + :fn-expr (interpret-fn ast ctx) - ::ast/pipeline (interpret-do ast ctx) + :do-expr (interpret-do ast ctx) - ::ast/placeholder ::data/placeholder + :placeholder ::data/placeholder - ::ast/ns (interpret-ns ast ctx) + :ns-expr (interpret-ns ast ctx) - ::ast/import (interpret-import ast ctx) + :import-expr (interpret-import ast ctx) - ::ast/ref (interpret-ref ast ctx) + :ref-expr (interpret-ref ast ctx) - ::ast/panic (panic ast ctx) + :when-expr (interpret-ast (-> ast :data first) ctx) - ::ast/spawn (interpret-spawn ast ctx) + ; ::ast/spawn (interpret-spawn ast ctx) - ::ast/send (interpret-send ast ctx) + ; ::ast/receive (interpret-receive ast ctx) - ::ast/receive (interpret-receive ast ctx) + :recur-call + {::data/recur true :args (interpret-ast (-> ast :data first) ctx)} - ::ast/recur - {::data/recur true :tuple (interpret-ast (:tuple ast) ctx)} + :loop-expr (interpret-loop ast ctx) - ::ast/loop (interpret-loop ast ctx) - - ::ast/block - (let [exprs (:exprs ast) + :block + (let [exprs (:data ast) inner (pop exprs) last (peek exprs) ctx (volatile! {::parent ctx})] (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,68 +878,75 @@ ;; 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 :args) + (let [members (:data ast)] + (into [::data/tuple] (map #(interpret-ast % ctx)) members)) - ::ast/list (interpret-list ast ctx) + :list-literal (interpret-list ast ctx) - ::ast/set - (interpret-set ast ctx) + :set-literal (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-literal + (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 interpret-file [parsed file] +(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 [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)))) -(defn interpret [parsed file] +;; TODO: update this to use new parser pipeline & new AST representation +(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) 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)))) (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)} - (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 "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 ([parsed ctx] (let [orig-ctx @ctx @@ -679,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!") @@ -690,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!") @@ -700,37 +976,22 @@ (comment - (process/start-vm) (def source " - let #{a, a} = #{:a 1} - a - ") + let 2 = 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 - * refactor accessing structs vs. hashes - - ") - - - - - diff --git a/src/ludus/interpreter_new.clj b/src/ludus/interpreter_new.clj new file mode 100644 index 0000000..cba232c --- /dev/null +++ b/src/ludus/interpreter_new.clj @@ -0,0 +1,38 @@ +(ns ludus.interpreter-new + (:require + [ludus.grammar :as g] + [ludus.parser-new :as p] + [ludus.scanner :as s])) + +(def source + "(1 2) +" + ) + +(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 + )) diff --git a/src/ludus/parser.clj b/src/ludus/parser.clj index 32eec68..cf5f0f3 100644 --- a/src/ludus/parser.clj +++ b/src/ludus/parser.clj @@ -1224,8 +1224,10 @@ (parser) (parse-script))) + (comment - (def my-source " + (do + (def my-source " data Foo {foo, bar} data Bar as { Bar @@ -1234,7 +1236,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/parser_new.clj b/src/ludus/parser_new.clj new file mode 100644 index 0000000..62eb781 --- /dev/null +++ b/src/ludus/parser_new.clj @@ -0,0 +1,334 @@ +(ns ludus.parser-new) + +(defn ? [val default] (if (nil? val) default val)) + +(defn ok? [{status :status}] + (= status :ok)) + +(def failing #{:err :none}) + +(def passing #{:ok :group :quiet}) + +(defn pass? [{status :status}] (contains? passing status)) + +(defn fail? [{status :status}] (contains? failing status)) + +(defn data [{d :data}] d) + +(defn remaining [{r :remaining}] r) + +(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)] + ;(if (= kw (:type token)) (println "Matched " kw)) + (if (= kw (:type token)) + {:status :ok + :type kw + :data (if (some? (value token)) [(value token)] []) + :token token + :remaining (rest tokens)} + {:status :none :token token :trace [kw] :remaining (rest tokens)}))) + +(defn apply-fn-parser [parser tokens] + (let [rule (: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)) + (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 + )) + +(defn choice [name parsers] + {:name name + :rule (fn choice-fn [tokens] + (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} + + (= :err (:status result)) + (update result :trace #(conj % name)) + + (empty? rem-ps) + {:status :none :token (first tokens) :trace [name] :remaining rem-ts} + + :else (recur rem-ps)))))}) + +(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) + (assoc (update first-result :trace #(conj % name)) :status :none) + + (: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} + + :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) + (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 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) + + (throw (ex-info (str "Got bad result: " (:status result)) result))))))))}) + +(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] + (let [result (apply-parser parser tokens)] + (if (pass? result) + (assoc result :status :quiet) + result)))}) + +(defn zero+ + ([parser] (zero+ (pname parser) parser)) + ([name parser] + {:name (kw+str name "-zero+") + :rule (fn zero+fn [tokens] + (loop [results [] + ts tokens] + (let [result (apply-parser parser ts)] + (case (: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)) + :none {:status :group + :type name + :data results + :token (first tokens) + :remaining ts}))))})) + +(defn one+ + ([parser] (one+ (pname parser) parser)) + ([name parser] + {:name (kw+str name "-one+") + :rule (fn one+fn [tokens] + (let [first-result (apply-parser parser tokens) + rest-parser (zero+ name parser)] + (case (:status first-result) + (:ok :group) + (let [rest-result (apply-parser rest-parser (remaining first-result))] + (case (:status rest-result) + + (:ok :group :quiet) + {:status :group + :type name + :data (vec (concat (:data 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))] + {:status :quiet + :type name + :data [] + :token (first tokens) + :remaining (remaining rest-result)}) + + (:err :none) first-result)))})) + +(defn maybe + ([parser] (maybe (pname parser) parser)) + ([name parser] + {:name (kw+str name "-maybe") + :rule (fn maybe-fn [tokens] + (let [result (apply-parser parser tokens)] + (if (pass? result) + result + {:status :group :type name :data [] :token (first tokens) :remaining tokens} + )))})) + +(defn flat + ([parser] (flat (pname parser) parser)) + ([name parser] + {:name (kw+str name "-flat") + :rule (fn flat-fn [tokens] + (let [result (apply-parser parser tokens)] + (if (pass? result) (first (: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))) + +(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)) diff --git a/src/ludus/prelude.clj b/src/ludus/prelude.clj index 575bb19..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}) @@ -93,23 +109,104 @@ (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)))}) -(comment - (def draw {:name "draw" +(def first- {:name "first" ::data/type ::data/clj - :body draw/ludus-draw}) + :body (fn [v] (second v))}) - (def draw {:name "draw" +(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] + (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)] + (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}) + +(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 count- {:name "count" ::data/type ::data/clj - :body d/draw})) + :body (fn [xs] (dec (count xs)))}) -(def prelude {"eq" eq +(def prelude { + "id" id + "eq" eq "add" add "print" print- "sub" sub "mult" mult "div" div + "gt" gt + "gte" gte + "lt" lt + "lte" lte "inc" inc- "dec" dec- "not" not @@ -122,5 +219,10 @@ "assoc" assoc- "conj" conj- "get" get- - ;"draw" draw + "type" type- + "clj" clj + "first" first- + "rest" rest- + "nth" nth- + "count" count- }) \ No newline at end of file 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/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)") diff --git a/src/ludus/scanner.clj b/src/ludus/scanner.clj index 7884bf7..bc2ac78 100644 --- a/src/ludus/scanner.clj +++ b/src/ludus/scanner.clj @@ -1,72 +1,79 @@ (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." ;; 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 -> literal word + "fn" :fn ;; impl + "if" :if ;; impl + "import" :import ;; impl + "let" :let ;; impl + "loop" :loop ;; impl + ; "match" :match ;; 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 -> literal word + "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 + "is" :is }) +(def literal-words { + "true" true + "false" false + "nil" nil + }) + (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,12 +82,12 @@ (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 - (>= (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)) @@ -107,11 +114,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))) @@ -120,28 +123,28 @@ ([scanner token-type] (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))))) + (update scanner :tokens conj + (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 - ::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] @@ -149,7 +152,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,28 +169,33 @@ (= 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 ".")))))) -;; 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) ::token/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) + (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] @@ -195,7 +203,9 @@ 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) + (get literal-words word :none)) (word-char? curr) (recur (advance scanner) (str word curr)) :else (add-error scanner (str "Unexpected " curr " after word " word ".")))))) @@ -205,7 +215,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 +225,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 +234,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,69 +243,52 @@ 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) + ;; :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 (add-token scanner :break) :rbrace) + \[ (add-token scanner :lbracket) + \] (add-token (add-token scanner :break) :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-error scanner (str "Expected <-. Got " char next))) - - ;; |> - ;; Consider => , with =>> for bind - ; \| (if (= next \>) - ; (add-token (advance scanner) ::token/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) ::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))) ;; 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 @@ -306,7 +299,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 @@ -316,20 +309,18 @@ (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)))))) (defn- next-token [scanner] - (assoc scanner ::start (::current scanner))) + (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 ::token/eof)] - {:tokens (::tokens scanner) - :errors (::errors scanner)}) + (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") - diff --git a/src/ludus/show.clj b/src/ludus/show.clj index beac45a..87f3e7e 100644 --- a/src/ludus/show.clj +++ b/src/ludus/show.clj @@ -1,31 +1,31 @@ (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) (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 (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))) "}") (::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))) "}") @@ -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 ", "))) 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}) 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