Add tuple patterns & matching
This commit is contained in:
parent
a4c5927ec4
commit
8368d6362d
|
@ -18,11 +18,39 @@
|
|||
(recur word (::parent ctx))
|
||||
(throw (new Exception (str "Unbound name: " word)))))))
|
||||
|
||||
(declare interpret)
|
||||
(declare interpret match)
|
||||
|
||||
(defn- match-tuple [pattern value ctx-atom]
|
||||
(cond
|
||||
(not (vector? value)) {:success false :reason "Could not match non-tuple value to tuple"}
|
||||
|
||||
(not (= ::colls/tuple (first value))) {:success false :reason "Could not match list to tuple"}
|
||||
|
||||
(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)]
|
||||
(loop [i (dec (:length pattern))
|
||||
ctx {}]
|
||||
(if (= 0 i)
|
||||
{:success true :ctx ctx}
|
||||
(let [match? (match (nth members i) (nth value (inc i)) ctx-atom)]
|
||||
(if (:success match?)
|
||||
(recur (dec i) (merge ctx (:ctx match?)))
|
||||
{:success false :reason (str "Could not match " pattern " with " value)}
|
||||
))
|
||||
)
|
||||
|
||||
))
|
||||
))
|
||||
|
||||
(defn- match [pattern value ctx-atom]
|
||||
(let [ctx @ctx-atom]
|
||||
(case (::ast/type pattern)
|
||||
::ast/placeholder {:success true :ctx {}}
|
||||
|
||||
::ast/atom
|
||||
(let [match-value (:value pattern)]
|
||||
(if (= match-value value)
|
||||
|
@ -37,6 +65,8 @@
|
|||
{:success true :ctx {word value}}
|
||||
))
|
||||
|
||||
::ast/tuple (match-tuple pattern value ctx-atom)
|
||||
|
||||
(do
|
||||
(println "ERROR! Unexpected pattern:")
|
||||
(pp/pprint pattern)
|
||||
|
@ -127,7 +157,7 @@
|
|||
(do
|
||||
|
||||
(def source "
|
||||
|
||||
let (:foo, 1, :bar) = (:foo, 1, :bar)
|
||||
")
|
||||
|
||||
(println "")
|
||||
|
|
|
@ -30,7 +30,7 @@
|
|||
(get-in parser [::ast ::ast/type]))
|
||||
|
||||
;; some forward declarations
|
||||
(declare parse-expr parse-word)
|
||||
(declare parse-expr parse-word parse-pattern)
|
||||
|
||||
;; handle some errors
|
||||
(def sync-on #{
|
||||
|
@ -314,14 +314,48 @@
|
|||
|
||||
(def sync-pattern (s/union sync-on #{::token/equals ::token/rarrow}))
|
||||
|
||||
(defn- parse-tuple-pattern [origin]
|
||||
(loop [
|
||||
parser (accept-many #{::token/newline ::token/comma} (advance origin))
|
||||
members []
|
||||
current_member nil
|
||||
]
|
||||
(let [curr (current parser)]
|
||||
(case (token-type parser)
|
||||
::token/rparen (let [ms (add-member members current_member)]
|
||||
(assoc (advance parser) ::ast
|
||||
{::ast/type ::ast/tuple
|
||||
:length (count ms)
|
||||
:members ms}))
|
||||
|
||||
(::token/comma ::token/newline)
|
||||
(recur
|
||||
(accept-many #{::token/comma ::token/newline} parser)
|
||||
(add-member members current_member) nil)
|
||||
|
||||
(::token/rbrace ::token/rbracket)
|
||||
(panic parser (str "Mismatched enclosure in tuple: " (::token/lexeme curr)))
|
||||
|
||||
::token/eof
|
||||
(panic (assoc origin ::errors (::errors parser)) "Unterminated tuple" ::token/eof)
|
||||
|
||||
(let [parsed (parse-pattern parser)]
|
||||
(recur parsed members (::ast parsed)))))))
|
||||
|
||||
(defn- parse-pattern [parser]
|
||||
(let [curr (current parser)
|
||||
type (::token/type curr)]
|
||||
(case type
|
||||
::token/placeholder (-> parser
|
||||
(advance)
|
||||
(assoc ::ast {::ast/type ::ast/placeholder}))
|
||||
|
||||
::token/word (parse-word parser)
|
||||
|
||||
(::token/number ::token/string ::token/keyword) (parse-atom parser)
|
||||
|
||||
::token/lparen (parse-tuple-pattern parser)
|
||||
|
||||
::token/error
|
||||
(panic parser (:message (current parser)) sync-pattern)
|
||||
|
||||
|
@ -428,7 +462,7 @@
|
|||
|
||||
(do
|
||||
(def pp pp/pprint)
|
||||
(def source "42")
|
||||
(def source "let () = ()")
|
||||
(def lexed (scanner/scan source))
|
||||
(def tokens (:tokens lexed))
|
||||
(def p (parser tokens))
|
||||
|
@ -441,7 +475,7 @@
|
|||
|
||||
(-> p
|
||||
(parse-script)
|
||||
;;(::ast)
|
||||
(::ast)
|
||||
(pp)
|
||||
)
|
||||
)
|
||||
|
|
Loading…
Reference in New Issue
Block a user