ludus/janet/interpreter.janet

# 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)
)