ludus/janet/interpreter.janet

# A tree walk interpreter for ludus

(import /src/base :as b)

(var interpret nil)
(var match-pattern nil)

(defn- todo [msg] (error (string "not yet implemented: " msg)))

(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 " (b/show 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 (b/ludus/type 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))
  (when (empty? members)
    (break (if (empty? value) 
      {:success true :ctx ctx}
      {:success false :miss [pattern value]})))
  (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 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))
  (when (empty? members)
    (break (if (empty? value) 
      {:success true :ctx ctx}
      {:success false :miss [pattern value]})))
  (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]
  (when (not (table? value))
    (break {:success false :miss [pattern value]}))
  (def val-size (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-size patt-len)
  #     (print "mismatched splatted dict 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-size patt-len))
  #   (print "mismatched dict lengths")
    (break {:success false :miss [pattern value]}))
  (var success true)
  (def matched-keys @[])
  (for i 0 (length members)
    (def curr-pair (get members i))
    (def [curr-key curr-patt] (curr-pair :data))
    (def key (interpret curr-key ctx))
    (def curr-val (value key))
    (def match? (match-pattern curr-patt curr-val ctx))
    (array/push matched-keys key)
    (when (not (match? :success))
      (set success false)
      (break)))
  (when (and splat? (splat :data) success)
    (def rest (merge value))
    (each key matched-keys
      (set (rest key) nil))
    (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)
    :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]
  # (print "lett!")
  # (pp ast)
  (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: let binding"})))

(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: match form"}))
    (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
      (b/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- to_string [ctx] (fn [x] 
  (if (buffer? x) 
    (string x)
    (b/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 (b/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 (b/bool (interpret lhs ctx))
      (set result (interpret rhs ctx))
      (break)))
  (when (= result :^nothing)
    (error {:node ast :msg "no match: when form"}))
  result)

(defn- word [ast ctx]
  (def resolved (resolve-name (ast :data) ctx))
  (if (= :^not-found resolved)
    (error {:node ast :msg "unbound name"})
    resolved))

(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 value) 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))
  (def box @{:^type :box :^value value :name name})
  (set (ctx name) box)
  box)

(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 :doc doc} ast)
  # (print "defining fn " name)
  (def closure (merge ctx))
  (def the-fn @{:name name :^type :fn :body clauses :ctx closure :doc doc})
  (when (not= :^not-found (resolve-name name ctx))
  #   (print "fn "name" was forward declared")
    (def fwd (resolve-name name ctx))
    (set (fwd :body) clauses)
    (set (fwd :ctx) closure)
    (set (fwd :doc) doc)
  #   (print "fn " name " has been defined")
  #   (pp fwd)
    (break fwd))
  # (pp the-fn)
  (set (closure name) the-fn)
  (set (ctx name) the-fn)
  the-fn)

(defn- is_placeholder [x] (= x :_))

(var call-fn nil)

(defn- partial [root-ast the-fn partial-args] 
  (when (the-fn :applied)
    (error {:msg "cannot partially apply a partially applied function"
      :node root-ast :called the-fn :args partial-args}))
  # (print "calling partially applied function")
  (def args (partial-args :args))
  # (pp args)
  (def pos (find-index is_placeholder args))
  (def name (string (the-fn :name) " *partial*"))
  (defn partial-fn [root-ast missing]
  #   (print "calling function with arg " (b/show missing))
  #   (pp partial-args)
    (def full-args (array/slice args))
    (set (full-args pos) missing)
  #   (print "all args: " (b/show full-args))
    (call-fn root-ast the-fn [;full-args]))
  {:^type :fn :applied true :name name :body partial-fn})

(defn- call-fn* [root-ast the-fn args]
   # (print "on line " (get-in root-ast [:token :line]))
   # (print "calling " (b/show the-fn))
   # (print "with args " (b/show args))
   # (pp args)
  (when (or 
    (= :function (type the-fn)) 
    (= :cfunction (type the-fn))) 
  #     (print "Janet function")
      (break (the-fn ;args)))
  (def clauses (the-fn :body))
  (when (= :nothing clauses)
    (error {:node root-ast :called the-fn :value args :msg "cannot call function before it is defined"}))
  (when (= :function (type clauses))
    (break (clauses root-ast ;args)))
  (def len (length clauses))
  (when (the-fn :match) (break ((the-fn :match) root-ast 0 args)))
  (defn match-fn [root-ast i args]
    (when (= len i)
      (error {:node root-ast :called the-fn :value args :msg "no match: function call"}))
    (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 root-ast (inc i) args)))
  #   (print "matched!")
    (def body-ctx (match? :ctx))
    (def guard? (if guard
      (b/bool (interpret guard body-ctx)) true))
  #   (print "passed guard")
    (when (not guard?) 
      (break (match-fn root-ast (inc i) args)))
    (interpret expr body-ctx))
  (set (the-fn :match) match-fn)
  (match-fn root-ast 0 args))

(set call-fn call-fn*)

(defn- call-partial [root-ast the-fn arg] ((the-fn :body) root-ast ;arg))

(defn- apply-synth-term [root-ast prev curr]
  # (print "applying " (b/show prev))
  # (print "to" (b/show curr))
  (def types [(b/ludus/type prev) (b/ludus/type curr)])
  # (print "typle:")
  # (pp types)
  (match types
    [:fn :tuple] (call-fn root-ast prev curr)
    [:fn :partial] (partial root-ast prev curr)
    [:function :tuple] (call-fn root-ast prev curr)
    # [:applied :tuple] (call-partial root-ast 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)
    (error (string "cannot call " (b/ludus/type prev) " `" (b/show prev) "`"))))

(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 first-term prev curr)))
  # (print "done with inner terms, applying last term")
  (apply-synth-term first-term prev (interpret last-term ctx)))

(defn- doo [ast ctx] 
  (def terms (ast :data))
  (var prev (interpret (first terms) ctx))
  (def last-term (last terms))
  (for i 1 (-> terms length dec)
    (def curr (interpret (terms i) ctx))
    (set prev (call-fn (first terms) curr [prev])))
  (def last-fn (interpret last-term ctx))
  (call-fn (first terms) last-fn [prev]))

(defn- pkg [ast ctx] 
  (def members (ast :data))
  (def the-pkg @{:^name (ast :name) :^type :pkg})
  (each member members
    (def [key-ast value-ast] (member :data))
    (def key (interpret key-ast ctx))
    (def value (interpret value-ast ctx))
    (set (the-pkg key) value))
  # (pp the-pkg)
  (def out (table/to-struct the-pkg))
  (set (ctx (ast :name)) out)
  out)

(defn- loopp [ast ctx]
  # (print "looping!")
  (def data (ast :data))
  (def args (interpret (data 0) ctx))
  # this doesn't work: context persists between different interpretations
  # we want functions to work this way, but not loops (I think)
  # (when (ast :match) (break ((ast :match) 0 args)))
  (def clauses (data 1))
  (def len (length clauses))
  (var loop-ctx @{:^parent ctx})
  (defn match-fn [i args]
    (when (= len i)
      (error {:node ast :value args :msg "no match: loop"}))
    (def clause (clauses i))
    (def [patt guard expr] clause)
    (def match?
      (match-pattern patt args loop-ctx))
    (when (not (match? :success))
  #     (print "no match")
      (break (match-fn (inc i) args)))
  #   (print "matched!")
    (def body-ctx (match? :ctx))
    (def guard? (if guard
      (b/bool (interpret guard body-ctx)) true))
  #   (print "passed guard")
    (when (not guard?) 
      (break (match-fn (inc i) args)))
    (interpret expr body-ctx))
  (set (ast :match) match-fn)
  (set (loop-ctx :^recur) match-fn)
  # (print "ATTACHED MATCH-FN")
  (match-fn 0 args))

(defn- recur [ast ctx]
  # (print "recurring!")
  (def passed (ast :data))
  (def args (interpret passed ctx))
  (def match-fn (resolve-name :^recur ctx))
  # (print "match fn in ctx:")
  # (pp (ctx :^recur))
  # (pp match-fn)
  # (pp ctx)
  (match-fn 0 args))

# TODO for 0.1.0
(defn- testt [ast ctx] (todo "test"))

(defn- ns [ast ctx] (todo "nses"))

(defn- importt [ast ctx] (todo "imports"))

(defn- withh [ast ctx] (todo "with"))

(defn- usee [ast ctx] (todo "use"))

(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)
    :pkg (pkg ast ctx)
    :pkg-name (word 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)
    # :ns (ns ast ctx)
    # :use (usee ast ctx)
    # :test (testt ast ctx)

    ))

(set interpret interpret*)

# # repl
# (import /src/scanner :as s)
# (import /src/parser :as p)
# (import /src/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 b/ctx))
#   # (when (has-errors? validated) (break (validated :errors)))
#   # (def cleaned (get-in parsed [:ast :data 1]))
#   # # (pp cleaned)
#   (interpret (parsed :ast) @{:^parent b/lett})
#   # (try (interpret (parsed :ast) @{:^parent b/ctx})
#   #   ([e] (if (struct? e) (error (e :msg)) (error e))))
#   )

# # (do 
# (comment
# (set source `
# let foo = 42
# "{foo} bar baz"
# `)
# (def result (run))
# )