514 lines
14 KiB
Plaintext
514 lines
14 KiB
Plaintext
# A tree walk interpreter for ludus
|
|
|
|
(var interpret nil)
|
|
(var stringify nil)
|
|
(var match-pattern nil)
|
|
|
|
(defn- todo [msg] (error (string "not yet implemented: " msg)))
|
|
|
|
(defn- ltype [value]
|
|
(def typed? (when (dictionary? value) (value :^type)))
|
|
(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))
|
|
(when (empty? members)
|
|
(break (if (empty? value)
|
|
{:success true :ctx ctx}
|
|
{:success false :miss [pattern value]})))
|
|
(var splat nil)
|
|
(def splat? (= :splat ((last members) :type)))
|
|
(when splat?
|
|
(when (< val-len patt-len)
|
|
(print "mismatched splatted tuple lengths")
|
|
(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 list lengths")
|
|
(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 list 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 list, 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-string [pattern value ctx]
|
|
(when (not (string? value))
|
|
(break {:success false :miss [pattern value]}))
|
|
(def {:compiled compiled :bindings bindings} pattern)
|
|
(print "matching " value " with")
|
|
(pp (pattern :grammar))
|
|
(def matches (peg/match compiled value))
|
|
(when (not matches)
|
|
(break {:success false :miss [pattern value]}))
|
|
(when (not= (length matches) (length bindings))
|
|
(error "oops: different number of matches and bindings"))
|
|
(for i 0 (length matches)
|
|
(set (ctx (bindings i)) (matches i)))
|
|
{:success true :ctx ctx})
|
|
|
|
(defn- match-dict [pattern value ctx] (todo "dict pattern"))
|
|
|
|
(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)
|
|
:dict (match-dict pattern value ctx)
|
|
|
|
:interpolated (match-string pattern value ctx)
|
|
|
|
: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))
|
|
value)
|
|
(error {:node ast :value value :msg "no match"})))
|
|
|
|
(defn- matchh [ast ctx]
|
|
(def [to-match clauses] (ast :data))
|
|
(def value (interpret to-match ctx))
|
|
(def len (length clauses))
|
|
(when (ast :match) (break ((ast :match) 0 value ctx)))
|
|
(defn match-fn [i value ctx]
|
|
(when (= len i)
|
|
(error {:node ast :value value :msg "no match"}))
|
|
(def clause (clauses i))
|
|
(def [patt guard expr] clause)
|
|
(def match? (match-pattern patt value @{:^parent ctx}))
|
|
(when (not (match? :success))
|
|
(break (match-fn (inc i) value ctx)))
|
|
(def body-ctx (match? :ctx))
|
|
(def guard? (if guard
|
|
(bool (interpret guard body-ctx)) true))
|
|
(when (not guard?)
|
|
(break (match-fn (inc i) value ctx)))
|
|
(interpret expr body-ctx))
|
|
(set (ast :match) match-fn)
|
|
(match-fn 0 value ctx))
|
|
|
|
(defn- script [ast ctx]
|
|
(def lines (ast :data))
|
|
(def last-line (last lines))
|
|
(for i 0 (-> lines length dec)
|
|
(interpret (lines i) ctx))
|
|
(interpret last-line ctx))
|
|
|
|
(defn- block [ast parent]
|
|
(def lines (ast :data))
|
|
(def last-line (last lines))
|
|
(def ctx @{:^parent parent})
|
|
(for i 0 (-> lines length dec)
|
|
(interpret (lines i) ctx))
|
|
(interpret last-line ctx))
|
|
|
|
(defn- dict-str [dict]
|
|
(string/join
|
|
(map
|
|
(fn [[k v]] (string (stringify k) " " (stringify v)))
|
|
(pairs dict))
|
|
", "))
|
|
|
|
(defn- stringify* [value]
|
|
(print "stringifying " (string value))
|
|
(def typed? (when (dictionary? value)
|
|
(print "value is a dictionary")
|
|
(value :^type)))
|
|
(def type (if typed? typed? (type 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))
|
|
:fn (string "fn " (value :name))
|
|
# XXX: pkg, fn
|
|
))
|
|
|
|
(set stringify stringify*)
|
|
|
|
(defn- stringish? [x] (or (string? x) (buffer? x)))
|
|
|
|
(defn- to_string [ctx] (fn [x]
|
|
(if (stringish? x) x (stringify (interpret x ctx)))))
|
|
|
|
(defn- interpolated [ast ctx]
|
|
(def terms (ast :data))
|
|
(def interpolations (map (to_string 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)))
|
|
|
|
# TODO: use a tail call here
|
|
(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]
|
|
(resolve-name (ast :data) ctx))
|
|
|
|
(defn- tup [ast ctx]
|
|
(def members (ast :data))
|
|
(def the-tup @[])
|
|
(each member members
|
|
(array/push the-tup (interpret member ctx)))
|
|
[;the-tup])
|
|
|
|
(defn- args [ast ctx]
|
|
(def members (ast :data))
|
|
(def the-args @[])
|
|
(each member members
|
|
(array/push the-args (interpret member ctx)))
|
|
(if (ast :partial)
|
|
{:^type :partial :args the-args}
|
|
[;the-args]))
|
|
|
|
(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))
|
|
(print "dict key")
|
|
(pp key-ast)
|
|
(print "dict value")
|
|
(pp value-ast)
|
|
(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}))
|
|
|
|
# TODO: add docstrings & pattern docs to fns
|
|
# Depends on: good string representation of patterns
|
|
# For now, this should be enough to tall the thing
|
|
(defn- fnn [ast ctx]
|
|
(def {:name name :data clauses} ast)
|
|
(def the-fn @{:name name :^type :fn :body clauses :ctx ctx})
|
|
(set (ctx name) the-fn))
|
|
|
|
# TODO
|
|
(defn- partial [the-fn args] (todo "partially applied functions"))
|
|
|
|
(defn- call-fn [the-fn args]
|
|
(print "calling fn " (the-fn :name))
|
|
(print "with args " args)
|
|
(def clauses (the-fn :body))
|
|
(def len (length clauses))
|
|
(when (the-fn :match) (break ((the-fn :match) 0 args)))
|
|
(defn match-fn [i args]
|
|
(when (= len i)
|
|
(error {:node the-fn :value args :msg "no match"}))
|
|
(def clause (clauses i))
|
|
(def [patt guard expr] clause)
|
|
(def match?
|
|
(match-pattern patt args @{:^parent (the-fn :ctx)}))
|
|
(when (not (match? :success))
|
|
(break (match-fn (inc i) args)))
|
|
(print "matched!")
|
|
(def body-ctx (match? :ctx))
|
|
(def guard? (if guard
|
|
(bool (interpret guard body-ctx)) true))
|
|
(print "passed guard")
|
|
(when (not guard?)
|
|
(break (match-fn (inc i) args)))
|
|
(interpret expr body-ctx))
|
|
(set (the-fn :match) match-fn)
|
|
(match-fn 0 args))
|
|
|
|
(defn- apply-synth-term [prev curr]
|
|
(print "applying")
|
|
(pp curr)
|
|
(print "to")
|
|
(pp prev)
|
|
(def types [(ltype prev) (ltype curr)])
|
|
(print "typle:")
|
|
(pp types)
|
|
(match types
|
|
[:fn :tuple] (call-fn prev curr)
|
|
[:fn :partial] (partial prev curr)
|
|
[:keyword :args] (get (first curr) prev :^nil)
|
|
[:dict :keyword] (get prev curr :^nil)
|
|
[:nil :keyword] :^nil
|
|
[:pkg :keyword] (get prev curr :^nil)
|
|
[:pkg :pkg-kw] (get prev curr :^nil)))
|
|
|
|
(defn- synthetic [ast ctx]
|
|
(def terms (ast :data))
|
|
(print "interpreting synthetic")
|
|
(pp ast)
|
|
(pp terms)
|
|
(def first-term (first terms))
|
|
(def last-term (last terms))
|
|
(var prev (interpret first-term ctx))
|
|
(print "root term: ")
|
|
(pp prev)
|
|
(for i 1 (-> terms length dec)
|
|
(def curr (interpret (terms i) ctx))
|
|
(print "term " i ": " curr)
|
|
(set prev (apply-synth-term prev curr)))
|
|
(print "done with inner terms, applying last term")
|
|
(apply-synth-term prev (interpret last-term ctx)))
|
|
|
|
(defn- doo [ast ctx] (todo "do expressions"))
|
|
|
|
(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)
|
|
:placeholder :_
|
|
|
|
# collections
|
|
:tuple (tup ast ctx)
|
|
:args (args 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)
|
|
|
|
# do
|
|
:do (doo 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)))
|
|
(def cleaned (get-in parsed [:ast :data 1]))
|
|
(pp cleaned)
|
|
(interpret (parsed :ast) @{})
|
|
# (try (interpret (parsed :ast) @{})
|
|
# ([e] (print "Ludus panicked!: "
|
|
# (if (struct? e) (error (e :msg)) (error e)))))
|
|
)
|
|
|
|
(do
|
|
(set source `
|
|
#{:a 1, :b 2}
|
|
`)
|
|
(def result (run))
|
|
(stringify result)
|
|
)
|
|
|