ludus/janet/interpreter.janet
2024-05-19 16:18:52 -04:00

548 lines
15 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)))
(print "value of type " type)
(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))
:function (string "builtin " (string value))
:cfunction (string "builtin " (string value))
# 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)
[:function :tuple] (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- pkg [ast ctx] (todo "pkgs"))
(defn- ns [ast ctx] (todo "nses"))
(defn- loopp [ast ctx] (todo "loops"))
(defn- recur [ast ctx] (todo "recur"))
(defn- repeatt [ast ctx] (todo "repeat"))
(defn - testt [ast ctx] (todo "test"))
(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)
# looping forms
:loop (loopp ast ctx)
:recur (recur ast ctx)
:repeat (repeatt 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)
# functions
:fn (fnn ast ctx)
# synthetic
:synthetic (synthetic ast ctx)
# do
:do (doo ast ctx)
# deferred until after computer class
# :with (withh ast ctx)
# :import (importt 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))))
(def base {
"ludus-type" ltype
"print" print
"add" +
"sub" -
"stringify" stringify
})
(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 base))
(when (has-errors? validated) (break (validated :errors)))
# (def cleaned (get-in parsed [:ast :data 1]))
# (pp cleaned)
(interpret (parsed :ast) @{:^parent base})
# (try (interpret (parsed :ast) @{})
# ([e] (print "Ludus panicked!: "
# (if (struct? e) (error (e :msg)) (error e)))))
)
(do
(set source `
print
`)
(def result (run))
(stringify result)
)
(string print)