Add splats to list patterns in parser

This commit is contained in:
Scott Richmond 2022-06-19 14:48:53 -04:00
parent 4254359934
commit 68bc37ef61

View File

@ -1,10 +1,10 @@
(ns ludus.parser (ns ludus.parser
(:require (:require
[ludus.token :as token] [ludus.token :as token]
[ludus.scanner :as scanner] [ludus.scanner :as scanner]
[ludus.ast :as ast] [ludus.ast :as ast]
[clojure.pprint :as pp] [clojure.pprint :as pp]
[clojure.set :as s])) [clojure.set :as s]))
;; a parser map and some functions to work with them ;; a parser map and some functions to work with them
(defn- parser [tokens] (defn- parser [tokens]
@ -47,8 +47,8 @@
:origin origin :origin origin
:end end}] :end end}]
(-> parser (-> parser
(assoc ::ast poison) (assoc ::ast poison)
(update ::errors conj poison)))) (update ::errors conj poison))))
(defn- poisoned? [parser] (defn- poisoned? [parser]
(= ::ast/poison (get-in parser [::ast ::ast/type]))) (= ::ast/poison (get-in parser [::ast ::ast/type])))
@ -74,8 +74,8 @@
(if (contains? tokens type) (if (contains? tokens type)
(advance parser) (advance parser)
(-> parser (-> parser
(advance) (advance)
(panic message tokens))))) (panic message tokens)))))
(defn- expect* [tokens message parser] (defn- expect* [tokens message parser]
(let [curr (current parser) (let [curr (current parser)
@ -106,10 +106,10 @@
(defn- parse-atom [parser] (defn- parse-atom [parser]
(let [token (current parser)] (let [token (current parser)]
(-> parser (-> parser
(advance) (advance)
(assoc ::ast {::ast/type ::ast/atom (assoc ::ast {::ast/type ::ast/atom
:token token :token token
:value (::token/literal token)})))) :value (::token/literal token)}))))
;; just a quick and dirty map to associate atomic words with values ;; just a quick and dirty map to associate atomic words with values
(def atomic-words {::token/nil nil (def atomic-words {::token/nil nil
@ -119,10 +119,10 @@
(defn parse-atomic-word [parser] (defn parse-atomic-word [parser]
(let [token (current parser)] (let [token (current parser)]
(-> parser (-> parser
(advance) (advance)
(assoc ::ast {::ast/type ::ast/atom (assoc ::ast {::ast/type ::ast/atom
:token token :token token
:value (get atomic-words (::token/type token))})))) :value (get atomic-words (::token/type token))}))))
(defn- add-member [members member] (defn- add-member [members member]
(if (nil? member) (if (nil? member)
@ -140,16 +140,16 @@
(case (token-type parser) (case (token-type parser)
::token/rparen (let [ms (add-member members current_member)] ::token/rparen (let [ms (add-member members current_member)]
(assoc (advance parser) ::ast (assoc (advance parser) ::ast
{::ast/type ::ast/tuple {::ast/type ::ast/tuple
:length (count ms) :length (count ms)
:members ms :members ms
:token (current origin) :token (current origin)
:partial (contains-placeholder? ms)})) :partial (contains-placeholder? ms)}))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbrace ::token/rbracket) (::token/rbrace ::token/rbracket)
(panic parser (str "Mismatched enclosure in tuple: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in tuple: " (::token/lexeme curr)))
@ -157,11 +157,11 @@
::token/placeholder ::token/placeholder
(if (contains-placeholder? members) (if (contains-placeholder? members)
(recur (recur
(advance parser) (advance parser)
members members
(panic parser "Partially applied functions must be unary. (Only one placeholder allowed in partial application.)" curr)) (panic parser "Partially applied functions must be unary. (Only one placeholder allowed in partial application.)" curr))
(recur (recur
(advance parser) members {::ast/type ::ast/placeholder :token curr})) (advance parser) members {::ast/type ::ast/placeholder :token curr}))
::token/eof ::token/eof
(panic (assoc origin ::errors (::errors parser)) "Unterminated tuple" ::token/eof) (panic (assoc origin ::errors (::errors parser)) "Unterminated tuple" ::token/eof)
@ -177,24 +177,24 @@
(case (token-type parser) (case (token-type parser)
::token/rparen (let [ms (add-member members current_member)] ::token/rparen (let [ms (add-member members current_member)]
(assoc (advance parser) ::ast (assoc (advance parser) ::ast
{::ast/type ::ast/tuple {::ast/type ::ast/tuple
:token (current origin) :token (current origin)
:length (count ms) :length (count ms)
:members ms})) :members ms}))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbrace ::token/rbracket) (::token/rbrace ::token/rbracket)
(panic parser (str "Mismatched enclosure in tuple: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in tuple: " (::token/lexeme curr)))
::token/placeholder ::token/placeholder
(recur (recur
(advance parser) (advance parser)
members members
(panic parser "Placeholders in tuples may only be in function calls." curr)) (panic parser "Placeholders in tuples may only be in function calls." curr))
::token/eof ::token/eof
(panic (assoc origin ::errors (::errors parser)) "Unterminated tuple" ::token/eof) (panic (assoc origin ::errors (::errors parser)) "Unterminated tuple" ::token/eof)
@ -202,7 +202,7 @@
(if current_member (if current_member
(panic parser "Comma expected between tuple members") (panic parser "Comma expected between tuple members")
(let [parsed (parse-expr parser #{::token/comma ::token/newline ::token/rparen})] (let [parsed (parse-expr parser #{::token/comma ::token/newline ::token/rparen})]
(recur parsed members (::ast parsed)))))))) (recur parsed members (::ast parsed))))))))
(defn- parse-list [origin] (defn- parse-list [origin]
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin)) (loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
@ -212,14 +212,14 @@
(case (token-type parser) (case (token-type parser)
::token/rbracket (let [ms (add-member members current_member)] ::token/rbracket (let [ms (add-member members current_member)]
(assoc (advance parser) ::ast (assoc (advance parser) ::ast
{::ast/type ::ast/list {::ast/type ::ast/list
:token (current origin) :token (current origin)
:members ms})) :members ms}))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbrace ::token/rparen) (::token/rbrace ::token/rparen)
(panic parser (str "Mismatched enclosure in list: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in list: " (::token/lexeme curr)))
@ -238,7 +238,7 @@
(if current_member (if current_member
(panic parser "Comma expected between list members") (panic parser "Comma expected between list members")
(let [parsed (parse-expr parser #{::token/comma ::token/newline ::token/rbracket})] (let [parsed (parse-expr parser #{::token/comma ::token/newline ::token/rbracket})]
(recur parsed members (::ast parsed)))))))) (recur parsed members (::ast parsed))))))))
(defn- parse-set [origin] (defn- parse-set [origin]
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin)) (loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
@ -248,14 +248,14 @@
(case (token-type parser) (case (token-type parser)
::token/rbrace (let [ms (add-member members current_member)] ::token/rbrace (let [ms (add-member members current_member)]
(assoc (advance parser) ::ast (assoc (advance parser) ::ast
{::ast/type ::ast/set {::ast/type ::ast/set
:token (current origin) :token (current origin)
:members ms})) :members ms}))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbracket ::token/rparen) (::token/rbracket ::token/rparen)
(panic parser (str "Mismatched enclosure in set: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in set: " (::token/lexeme curr)))
@ -274,7 +274,7 @@
(if current_member (if current_member
(panic parser "Comma expected between set members") (panic parser "Comma expected between set members")
(let [parsed (parse-expr parser #{::token/comma ::token/newline ::token/rbrace})] (let [parsed (parse-expr parser #{::token/comma ::token/newline ::token/rbrace})]
(recur parsed members (::ast parsed)))))))) (recur parsed members (::ast parsed))))))))
(defn- parse-dict [origin] (defn- parse-dict [origin]
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin)) (loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
@ -284,14 +284,14 @@
(case (token-type parser) (case (token-type parser)
::token/rbrace (let [ms (add-member members current_member)] ::token/rbrace (let [ms (add-member members current_member)]
(assoc (advance parser) ::ast (assoc (advance parser) ::ast
{::ast/type ::ast/dict {::ast/type ::ast/dict
:token (current origin) :token (current origin)
:members ms})) :members ms}))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbracket ::token/rparen) (::token/rbracket ::token/rparen)
(panic parser (str "Mismatched enclosure in dict: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in dict: " (::token/lexeme curr)))
@ -331,14 +331,14 @@
(case (token-type parser) (case (token-type parser)
::token/rbrace (let [ms (add-member members current_member)] ::token/rbrace (let [ms (add-member members current_member)]
(assoc (advance parser) ::ast (assoc (advance parser) ::ast
{::ast/type ::ast/struct {::ast/type ::ast/struct
:token (current origin) :token (current origin)
:members ms})) :members ms}))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbracket ::token/rparen) (::token/rbracket ::token/rparen)
(panic parser (str "Mismatched enclosure in struct: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in struct: " (::token/lexeme curr)))
@ -349,12 +349,12 @@
::token/word ::token/word
(if (not current_member) (let [parsed (parse-word parser) word (get-in parsed [::ast :word])] (if (not current_member) (let [parsed (parse-word parser) word (get-in parsed [::ast :word])]
(recur parsed members {(keyword word) (::ast parsed)})) (recur parsed members {(keyword word) (::ast parsed)}))
(panic parser "Struct entries must be single words or keyword+expression pairs." #{::token/rbrace})) (panic parser "Struct entries must be single words or keyword+expression pairs." #{::token/rbrace}))
::token/keyword ::token/keyword
(if (not current_member) (let [kw (parse-atom parser) expr (parse-expr kw #{::token/comma ::token/newline ::token/rbrace})] (if (not current_member) (let [kw (parse-atom parser) expr (parse-expr kw #{::token/comma ::token/newline ::token/rbrace})]
(recur expr members {(:value (::ast kw)) (::ast expr)})) (recur expr members {(:value (::ast kw)) (::ast expr)}))
(panic parser "Struct entries must be single words or keyword+expression pairs." #{::token/rbrace})) (panic parser "Struct entries must be single words or keyword+expression pairs." #{::token/rbrace}))
(panic parser "Struct entries must be single words or keyword+expression pairs" #{::token/rbrace}))))) (panic parser "Struct entries must be single words or keyword+expression pairs" #{::token/rbrace})))))
@ -374,15 +374,15 @@
(case (token-type parser) (case (token-type parser)
::token/rbrace (let [ms (add-member members current_member)] ::token/rbrace (let [ms (add-member members current_member)]
(assoc (advance parser) ::ast (assoc (advance parser) ::ast
{::ast/type ::ast/ns {::ast/type ::ast/ns
:token (current ns-root) :token (current ns-root)
:name (get-in (parse-word (advance ns-root)) [::ast :word]) :name (get-in (parse-word (advance ns-root)) [::ast :word])
:members ms})) :members ms}))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbracket ::token/rparen) (::token/rbracket ::token/rparen)
(panic parser (str "Mismatched enclosure in ns: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in ns: " (::token/lexeme curr)))
@ -393,12 +393,12 @@
::token/word ::token/word
(if (not current_member) (let [parsed (parse-word parser) word (get-in parsed [::ast :word])] (if (not current_member) (let [parsed (parse-word parser) word (get-in parsed [::ast :word])]
(recur parsed members {(keyword word) (::ast parsed)})) (recur parsed members {(keyword word) (::ast parsed)}))
(panic parser "ns entries must be single words or keyword+expression pairs." #{::token/rbrace})) (panic parser "ns entries must be single words or keyword+expression pairs." #{::token/rbrace}))
::token/keyword ::token/keyword
(if (not current_member) (let [kw (parse-atom parser) expr (parse-expr kw #{::token/comma ::token/newline ::token/rbrace})] (if (not current_member) (let [kw (parse-atom parser) expr (parse-expr kw #{::token/comma ::token/newline ::token/rbrace})]
(recur expr members {(:value (::ast kw)) (::ast expr)})) (recur expr members {(:value (::ast kw)) (::ast expr)}))
(panic parser "ns entries must be single words or keyword+expression pairs." #{::token/rbrace})) (panic parser "ns entries must be single words or keyword+expression pairs." #{::token/rbrace}))
(panic parser "ns entries must be single words or keyword+expression pairs" #{::token/rbrace}))))))) (panic parser "ns entries must be single words or keyword+expression pairs" #{::token/rbrace})))))))
@ -418,8 +418,8 @@
(::token/semicolon ::token/newline) (::token/semicolon ::token/newline)
(recur (recur
(accept-many #{::token/newline ::token/semicolon} parser) (accept-many #{::token/newline ::token/semicolon} parser)
(add-member exprs current_expr) nil) (add-member exprs current_expr) nil)
(::token/rbracket ::token/rparen) (::token/rbracket ::token/rparen)
(panic parser (str "Mismatched enclosure in block: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in block: " (::token/lexeme curr)))
@ -447,9 +447,9 @@
(::token/semicolon ::token/newline) (::token/semicolon ::token/newline)
(recur (recur
(accept-many #{::token/semicolon ::token/newline} parser) (accept-many #{::token/semicolon ::token/newline} parser)
(add-member exprs current_expr) (add-member exprs current_expr)
nil) nil)
(let [parsed (let [parsed
(if current_expr (if current_expr
@ -479,27 +479,55 @@
(defn- parse-word [parser] (defn- parse-word [parser]
(let [curr (current parser)] (let [curr (current parser)]
(-> parser (-> parser
(advance) (advance)
(assoc ::ast {::ast/type ::ast/word :token (current parser) :word (::token/lexeme curr)})))) (assoc ::ast {::ast/type ::ast/word :token (current parser) :word (::token/lexeme curr)}))))
(def sync-pattern (s/union sync-on #{::token/equals ::token/rarrow})) (def sync-pattern (s/union sync-on #{::token/equals ::token/rarrow}))
(defn- parse-splat-pattern [origin]
(let [splatted (advance origin)]
(case (token-type splatted)
::token/word
(assoc (advance splatted) ::ast
{::ast/type ::ast/splat
:token (current origin)
:into (::ast (parse-word splatted))})
::token/placeholder
(assoc (advance splatted) ::ast
{::ast/type ::ast/splat
:token (current origin)
:into {::ast/type ::ast/placeholder :token (current splatted)}})
(::token/comma ::token/newline ::token/rbrace ::token/rparen ::token/rbracket)
(assoc splatted ::ast
{::ast/type ::ast/splat
:token (current origin)
:into {::ast/type ::ast/placeholder :token (current origin)}})
(panic origin "Splat patterns may only splat into words or placeholders.")
)))
(defn- parse-list-pattern [origin] (defn- parse-list-pattern [origin]
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin)) (loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
members [] members []
current_member nil] current_member nil]
(let [curr (current parser)] (let [curr (current parser)]
(case (token-type parser) (case (token-type parser)
::token/rbracket (let [ms (add-member members current_member)] ::token/rbracket
(assoc (advance parser) ::ast (let [ms (add-member members current_member)]
{::ast/type ::ast/list (if (not-any? #(= (::ast/type %) ::ast/splat) (drop-last ms))
:token (current origin) (assoc (advance parser) ::ast
:members ms})) {::ast/type ::ast/tuple
:token (current origin)
:length (count ms)
:members ms})
(panic parser "A splat my only appear once in a pattern, at the end of a pattern.")))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbrace ::token/rparen) (::token/rbrace ::token/rparen)
(panic parser (str "Mismatched enclosure in list pattern: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in list pattern: " (::token/lexeme curr)))
@ -507,6 +535,10 @@
::token/eof ::token/eof
(panic (assoc origin ::errors (::errors parser)) "Unterminated list pattern" ::token/eof) (panic (assoc origin ::errors (::errors parser)) "Unterminated list pattern" ::token/eof)
::token/splat
(let [splatted (parse-splat-pattern parser)]
(recur splatted members (::ast splatted)))
(let [parsed (parse-pattern parser)] (let [parsed (parse-pattern parser)]
(recur parsed members (::ast parsed))))))) (recur parsed members (::ast parsed)))))))
@ -518,14 +550,14 @@
(case (token-type parser) (case (token-type parser)
::token/rbrace (let [ms (add-member members current_member)] ::token/rbrace (let [ms (add-member members current_member)]
(assoc (advance parser) ::ast (assoc (advance parser) ::ast
{::ast/type ::ast/dict {::ast/type ::ast/dict
:token (current origin) :token (current origin)
:members ms})) :members ms}))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbracket ::token/rparen) (::token/rbracket ::token/rparen)
(panic parser (str "Mismatched enclosure in dict pattern: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in dict pattern: " (::token/lexeme curr)))
@ -555,14 +587,14 @@
(case (token-type parser) (case (token-type parser)
::token/rbrace (let [ms (add-member members current_member)] ::token/rbrace (let [ms (add-member members current_member)]
(assoc (advance parser) ::ast (assoc (advance parser) ::ast
{::ast/type ::ast/struct {::ast/type ::ast/struct
:token (current origin) :token (current origin)
:members ms})) :members ms}))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbracket ::token/rparen) (::token/rbracket ::token/rparen)
(panic parser (str "Mismatched enclosure in struct pattern: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in struct pattern: " (::token/lexeme curr)))
@ -584,23 +616,26 @@
(panic parser "Struct patterns may only include single words or keyword+pattern pairs." #{::token/rbrace}))))) (panic parser "Struct patterns may only include single words or keyword+pattern pairs." #{::token/rbrace})))))
(defn- parse-tuple-pattern [origin] (defn- parse-tuple-pattern [origin]
(loop [parser (accept-many #{::token/newline ::token/comma} (advance origin)) (loop [parser (accept-many #{::token/newline ::token/comma} (advance origin))
members [] members []
current_member nil] current_member nil]
(let [curr (current parser)] (let [curr (current parser)]
(case (token-type parser) (case (token-type parser)
::token/rparen (let [ms (add-member members current_member)] ::token/rparen
(assoc (advance parser) ::ast (let [ms (add-member members current_member)]
{::ast/type ::ast/tuple (assoc (advance parser) ::ast
:token (current origin) {::ast/type ::ast/tuple
:length (count ms) :token (current origin)
:members ms})) :length (count ms)
:members ms}))
(::token/comma ::token/newline) (::token/comma ::token/newline)
(recur (recur
(accept-many #{::token/comma ::token/newline} parser) (accept-many #{::token/comma ::token/newline} parser)
(add-member members current_member) nil) (add-member members current_member) nil)
(::token/rbrace ::token/rbracket) (::token/rbrace ::token/rbracket)
(panic parser (str "Mismatched enclosure in tuple: " (::token/lexeme curr))) (panic parser (str "Mismatched enclosure in tuple: " (::token/lexeme curr)))
@ -617,8 +652,8 @@
(case type (case type
(::token/placeholder ::token/ignored) (::token/placeholder ::token/ignored)
(-> parser (-> parser
(advance) (advance)
(assoc ::ast {::ast/type ::ast/placeholder :token curr})) (assoc ::ast {::ast/type ::ast/placeholder :token curr}))
::token/word (parse-word parser) ::token/word (parse-word parser)
@ -812,12 +847,12 @@
(defn- parse-cond-clause [parser] (defn- parse-cond-clause [parser]
(let [expr (if (let [expr (if
(contains? #{::token/else ::token/placeholder} (token-type parser)) (contains? #{::token/else ::token/placeholder} (token-type parser))
(-> parser (-> parser
(advance) (advance)
(assoc ::ast {::ast/type ::ast/atom (assoc ::ast {::ast/type ::ast/atom
:token (current parser) :token (current parser)
:value true})) :value true}))
(parse-expr parser)) (parse-expr parser))
rarrow (expect* #{::token/rarrow} "Expected arrow after expression in cond clause" expr)] rarrow (expect* #{::token/rarrow} "Expected arrow after expression in cond clause" expr)]
(if (:success rarrow) (if (:success rarrow)
@ -963,7 +998,7 @@
(defn- parse-send [parser] (defn- parse-send [parser]
(let [msg (parse-expr (advance parser)) (let [msg (parse-expr (advance parser))
to (expect* ::token/to "Expected `to` between message and PID" msg)] to (expect* ::token/to "Expected `to` between message and PID" msg)]
(if (:success to) (if (:success to)
(let [pid (parse-expr (:parser to))] (let [pid (parse-expr (:parser to))]
(assoc pid ::ast {::ast/type ::ast/send :token (current parser) :msg (::ast msg) :pid (::ast pid)})) (assoc pid ::ast {::ast/type ::ast/send :token (current parser) :msg (::ast msg) :pid (::ast pid)}))
@ -1066,14 +1101,13 @@
(defn parse [lexed] (defn parse [lexed]
(-> lexed (-> lexed
(:tokens) (:tokens)
(parser) (parser)
(parse-script))) (parse-script)))
(comment (do
(def pp pp/pprint) (def pp pp/pprint)
(def source "if let foo = bar then foo else bar") (def source "let [a, b, (c, d), ...e] = [1, 2, (4, 5), 6]")
(println "") (println "")
(println "") (println "")