396 lines
10 KiB
Plaintext
396 lines
10 KiB
Plaintext
# A tree walk interpreter for ludus
|
|
|
|
(var interpret nil)
|
|
(var stringify nil)
|
|
(var match-pattern nil)
|
|
|
|
(defn- ltype [value]
|
|
(def typed? (when (table? value) (:^type value)))
|
|
(def the-type (if typed? typed? (type value)))
|
|
(case the-type
|
|
:boolean :bool
|
|
:array :list
|
|
:table :dict
|
|
the-type))
|
|
|
|
(defn- bool [value]
|
|
(if (= value :^nil nil) value))
|
|
|
|
(defn- resolve-name [name ctx]
|
|
(print "resolving " name " in:")
|
|
(pp ctx)
|
|
(when (not ctx) (break :^not-found))
|
|
(if (has-key? ctx name)
|
|
(ctx name)
|
|
(resolve-name name (ctx :^parent))))
|
|
|
|
(defn- match-word [word value ctx]
|
|
(def name (word :data))
|
|
(print "matched " (stringify value) " to " name)
|
|
(set (ctx name) value)
|
|
{:success true :ctx ctx})
|
|
|
|
(defn- typed [pattern value ctx]
|
|
(def [type-ast word] (pattern :data))
|
|
(def type (type-ast :data))
|
|
(if (= type (ltype value))
|
|
(match-word word value ctx)
|
|
{:success false :miss [pattern value]}))
|
|
|
|
(defn- match-tuple [pattern value ctx]
|
|
(when (not (tuple? value))
|
|
(break {:success false :miss [pattern value]}))
|
|
(def val-len (length value))
|
|
(var members (pattern :data))
|
|
(def patt-len (length members))
|
|
(var splat nil)
|
|
(def splat? (= :splat ((last members) :type)))
|
|
(when splat?
|
|
(when (< val-len patt-len)
|
|
(print "mismatched splatted tuple lenghts")
|
|
(break {:success false :miss [pattern value]}))
|
|
(print "splat!")
|
|
(set splat (last members))
|
|
(set members (slice members 0 (dec patt-len))))
|
|
(when (and (not splat?) (not= val-len patt-len))
|
|
(print "mismatched tuple lengths")
|
|
(break {:success false :miss [pattern value]}))
|
|
(var curr-mem :^nothing)
|
|
(var curr-val :^nothing)
|
|
(var success true)
|
|
(for i 0 (length members)
|
|
(set curr-mem (get members i))
|
|
(set curr-val (get value i))
|
|
(print "in tuple, matching " curr-val " with ")
|
|
(pp curr-mem)
|
|
(def match? (match-pattern curr-mem curr-val ctx))
|
|
(pp match?)
|
|
(when (not (match? :success))
|
|
(set success false)
|
|
(break)))
|
|
(when (and splat? (splat :data))
|
|
(def rest (array/slice value (length members)))
|
|
(match-word (splat :data) rest ctx))
|
|
(if success
|
|
{:success true :ctx ctx}
|
|
{:success false :miss [pattern value]}))
|
|
|
|
|
|
(defn- match-list [pattern value ctx]
|
|
(when (not (array? value))
|
|
(break {:success false :miss [pattern value]}))
|
|
(def val-len (length value))
|
|
(var members (pattern :data))
|
|
(def patt-len (length members))
|
|
(var splat nil)
|
|
(def splat? (= :splat ((last members) :type)))
|
|
(when splat?
|
|
(when (< val-len patt-len)
|
|
(print "mismatched splatted tuple lenghts")
|
|
(break {:success false :miss [pattern value]}))
|
|
(print "splat!")
|
|
(set splat (last members))
|
|
(set members (slice members 0 (dec patt-len))))
|
|
(when (and (not splat?) (not= val-len patt-len))
|
|
(print "mismatched tuple lengths")
|
|
(break {:success false :miss [pattern value]}))
|
|
(var curr-mem :^nothing)
|
|
(var curr-val :^nothing)
|
|
(var success true)
|
|
(for i 0 (length members)
|
|
(set curr-mem (get members i))
|
|
(set curr-val (get value i))
|
|
(print "in tuple, matching " curr-val " with ")
|
|
(pp curr-mem)
|
|
(def match? (match-pattern curr-mem curr-val ctx))
|
|
(pp match?)
|
|
(when (not (match? :success))
|
|
(set success false)
|
|
(break)))
|
|
(when (and splat? (splat :data))
|
|
(def rest (array/slice value (length members)))
|
|
(match-word (splat :data) rest ctx))
|
|
(if success
|
|
{:success true :ctx ctx}
|
|
{:success false :miss [pattern value]}))
|
|
|
|
(defn- match-pattern* [pattern value &opt ctx]
|
|
(print "in match-pattern, matching " value " with:")
|
|
(pp pattern)
|
|
(default ctx @{})
|
|
(def data (pattern :data))
|
|
(case (pattern :type)
|
|
# always match
|
|
:placeholder {:success true :ctx ctx}
|
|
:ignored {:success true :ctx ctx}
|
|
:word (match-word pattern value ctx)
|
|
|
|
# match on equality
|
|
:nil {:success (nil? value) :ctx ctx}
|
|
:bool {:success (= data value) :ctx ctx}
|
|
:number {:success (= data value) :ctx ctx}
|
|
:string {:success (= data value) :ctx ctx}
|
|
:keyword {:success (= data value) :ctx ctx}
|
|
|
|
# TODO: lists, dicts
|
|
:tuple (match-tuple pattern value ctx)
|
|
:list (match-list pattern value ctx)
|
|
# TODO: string-patterns
|
|
|
|
:typed (typed pattern value ctx)
|
|
))
|
|
|
|
(set match-pattern match-pattern*)
|
|
|
|
(defn- lett [ast ctx]
|
|
(def [patt expr] (ast :data))
|
|
(def value (interpret expr ctx))
|
|
(def match? (match-pattern patt value))
|
|
(if (match? :success)
|
|
(do
|
|
(merge-into ctx (match? :ctx))
|
|
(print "new ctx:")
|
|
(pp ctx)
|
|
value)
|
|
# TODO: represent patterns textually in errors
|
|
(error {:node ast
|
|
:msg (string "could not match " (stringify value))})))
|
|
|
|
(defn- matchh [ast ctx]
|
|
(def [to-match clauses] (ast :data))
|
|
(def value (interpret to-match ctx))
|
|
(var result :^nothing)
|
|
(each clause clauses
|
|
(def [patt guard expr] clause)
|
|
(print "matching ")
|
|
(pp patt)
|
|
(def match? (match-pattern patt value))
|
|
(when (match? :success)
|
|
(def inner-ctx (match? :ctx))
|
|
(def guard? (if (bool guard)
|
|
(interpret guard inner-ctx) true))
|
|
(when guard?
|
|
(set result (interpret expr inner-ctx))
|
|
(break))))
|
|
(if (= result :^nothing)
|
|
(error {:node ast :value value :msg "no match"})
|
|
result))
|
|
|
|
(defn- script [ast ctx]
|
|
(def lines (ast :data))
|
|
(var result nil)
|
|
(each line lines
|
|
(set result (interpret line ctx)))
|
|
result)
|
|
|
|
(defn- block [ast parent]
|
|
(def lines (ast :data))
|
|
(var result nil)
|
|
(def ctx @{:^parent parent})
|
|
(each line lines
|
|
(set result (interpret line ctx)))
|
|
result)
|
|
|
|
(defn- dict-str [dict]
|
|
(string/join
|
|
(map
|
|
(fn [[k v]] (string (stringify k) " " (stringify v)))
|
|
dict)
|
|
", "))
|
|
|
|
(defn- stringify* [value]
|
|
(def typed? (when (table? value) (:^type value)))
|
|
(def type (if typed? typed? (type value)))
|
|
(print "stringifying " (string value))
|
|
(case type
|
|
:nil ""
|
|
:number (string value)
|
|
:boolean (string value)
|
|
:keyword (string ":" value)
|
|
:string value
|
|
:tuple
|
|
(string/join (map stringify value) ", ")
|
|
:array
|
|
(string/join (map stringify value) ", ")
|
|
:table (dict-str value)
|
|
:set
|
|
(string/join (map stringify (keys value)) ", ")
|
|
:ref (stringify (value :^value))
|
|
# XXX: pkg, fn
|
|
))
|
|
|
|
(set stringify stringify*)
|
|
|
|
(defn- interpolated [ast ctx]
|
|
(def terms (ast :data))
|
|
(def interpolations
|
|
(map (fn [x]
|
|
(if (string? x) x (stringify (interpret x ctx))))
|
|
terms))
|
|
(string/join interpolations))
|
|
|
|
|
|
(defn- iff [ast ctx]
|
|
(def [condition then else] (ast :data))
|
|
(if (bool (interpret condition ctx))
|
|
(interpret then ctx)
|
|
(interpret else ctx)))
|
|
|
|
(defn- whenn [ast ctx]
|
|
(def clauses (ast :data))
|
|
(var result :^nothing)
|
|
(each clause clauses
|
|
(def [lhs rhs] clause)
|
|
(when (bool (interpret lhs ctx))
|
|
(set result (interpret rhs ctx))
|
|
(break)))
|
|
(when (= result :^nothing)
|
|
(error {:node ast :msg "no match in when"}))
|
|
result)
|
|
|
|
(defn- word [ast ctx]
|
|
(def name (ast :data))
|
|
(resolve-name name ctx))
|
|
|
|
(defn- tup [ast ctx]
|
|
(def members (ast :data))
|
|
(def the-tup @[])
|
|
(each member members
|
|
(array/push the-tup (interpret member ctx)))
|
|
(tuple ;the-tup))
|
|
|
|
(defn- sett [ast ctx]
|
|
(def members (ast :data))
|
|
(def the-set @{:^type :set})
|
|
(each member members
|
|
(def value (interpret member ctx))
|
|
(set (the-set member) true))
|
|
the-set)
|
|
|
|
(defn- list [ast ctx]
|
|
(def members (ast :data))
|
|
(def the-list @[])
|
|
(each member members
|
|
(if (= :splat (member :type))
|
|
(do
|
|
(def splatted (interpret (member :data) ctx))
|
|
(when (not= :array (type splatted))
|
|
(error {:node member :msg "cannot splat non-list into list"}))
|
|
(array/concat the-list splatted))
|
|
(array/push the-list (interpret member ctx))))
|
|
the-list)
|
|
|
|
(defn- dict [ast ctx]
|
|
(def members (ast :data))
|
|
(def the-dict @{})
|
|
(each member members
|
|
(if (= :splat (member :type))
|
|
(do
|
|
(def splatted (interpret (member :data) ctx))
|
|
(when (or
|
|
(not= :table (type splatted))
|
|
(:^type splatted))
|
|
(error {:node member :msg "cannot splat non-dict into dict"}))
|
|
(merge-into the-dict splatted))
|
|
(do
|
|
(def [key-ast value-ast] (member :data))
|
|
(def key (interpret key-ast ctx))
|
|
(def value (interpret value-ast ctx))
|
|
(set (the-dict key) value))))
|
|
the-dict)
|
|
|
|
(defn- ref [ast ctx]
|
|
(def {:data value-ast :name name} ast)
|
|
(def value (interpret value-ast ctx))
|
|
(set (ctx name) @{:^type :ref :^value value :^name name})
|
|
value)
|
|
|
|
(defn- repeatt [ast ctx]
|
|
(def [times-ast body] (ast :data))
|
|
(def times (interpret times-ast ctx))
|
|
(when (not (number? times))
|
|
(error {:node times-ast :msg (string "repeat needs a `number` of times; you gave me a " (type times))}))
|
|
(repeat times (interpret body ctx)))
|
|
|
|
(defn- panic [ast ctx]
|
|
(def info (interpret (ast :data) ctx))
|
|
(error {:node ast :msg info}))
|
|
|
|
(defn- interpret* [ast ctx]
|
|
(print "interpreting node " (ast :type))
|
|
(case (ast :type)
|
|
# literals
|
|
:nil :^nil
|
|
:number (ast :data)
|
|
:bool (ast :data)
|
|
:string (ast :data)
|
|
:keyword (ast :data)
|
|
|
|
# collections
|
|
:tuple (tup ast ctx)
|
|
:list (list ast ctx)
|
|
:set (sett ast ctx)
|
|
:dict (dict ast ctx)
|
|
|
|
# composite forms
|
|
:if (iff ast ctx)
|
|
:block (block ast ctx)
|
|
:when (whenn ast ctx)
|
|
:script (script ast ctx)
|
|
:panic (panic ast ctx)
|
|
|
|
# named/naming forms
|
|
:word (word ast ctx)
|
|
:interpolated (interpolated ast ctx)
|
|
:ref (ref ast ctx)
|
|
# :ns (ns ast ctx)
|
|
# :pkg (pkg ast ctx)
|
|
|
|
# patterned forms
|
|
:let (lett ast ctx)
|
|
:match (matchh ast ctx)
|
|
# :with (withh ast ctx)
|
|
|
|
# functions
|
|
# :fn (fnn ast ctx)
|
|
|
|
# synthetic
|
|
# :synthetic (synthetic ast ctx)
|
|
|
|
))
|
|
|
|
(set interpret interpret*)
|
|
|
|
# repl
|
|
(try (os/cd "janet") ([_] nil))
|
|
(import ./scanner :as s)
|
|
(import ./parser :as p)
|
|
(import ./validate :as v)
|
|
|
|
(var source nil)
|
|
|
|
(defn- has-errors? [{:errors errors}] (and errors (not (empty? errors))))
|
|
|
|
(defn run []
|
|
(def scanned (s/scan source))
|
|
(when (has-errors? scanned) (break (scanned :errors)))
|
|
(def parsed (p/parse scanned))
|
|
(when (has-errors? parsed) (break (parsed :errors)))
|
|
(def validated (v/valid parsed))
|
|
(when (has-errors? validated) (break (validated :errors)))
|
|
# (interpret (parsed :ast) @{})
|
|
(try (interpret (parsed :ast) @{})
|
|
([e] (print "Ludus panicked!: "
|
|
(if (struct? e) (error (e :msg)) (error e)))))
|
|
)
|
|
|
|
(do
|
|
(set source `
|
|
match "foo" with {
|
|
"f{ooo}o" -> ooo
|
|
_ -> :nope
|
|
}
|
|
`)
|
|
(run)
|
|
)
|