From 399f1fd4c72cbeeccb0f3125c92014d14892a256 Mon Sep 17 00:00:00 2001
From: Scott Richmond <kredati@users.noreply.github.com>
Date: Wed, 15 May 2024 00:05:25 -0400
Subject: [PATCH] make progress; WIP: interpreting pattern matching

---
 janet/base.janet        |  18 ++++
 janet/interpreter.janet | 210 +++++++++++++++++++++++++++++++++++++---
 janet/validate.janet    |   1 +
 3 files changed, 217 insertions(+), 12 deletions(-)

diff --git a/janet/base.janet b/janet/base.janet
index e69de29..913125f 100644
--- a/janet/base.janet
+++ b/janet/base.janet
@@ -0,0 +1,18 @@
+# A base library for Ludus
+# Only loaded in the prelude
+
+(defn- stringify [value]
+  (def typed? (when (table? value) (:^type value))
+  (def type (if typed? typed? (type value))
+  (case type
+    :nil ""
+    :number (string value)
+    :
+  )
+)
+
+(def show {
+  :name "show"
+  :fn ()
+})
+
diff --git a/janet/interpreter.janet b/janet/interpreter.janet
index 6468a36..54f63b2 100644
--- a/janet/interpreter.janet
+++ b/janet/interpreter.janet
@@ -1,6 +1,107 @@
 # A tree walk interpreter for ludus
 
 (var interpret nil)
+(var stringify nil)
+(var match-pattern nil)
+
+(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))
+  {:success true :ctx (set (ctx name) value)})
+
+(defn- match-pattern [pattern value &opt ctx]
+  (default ctx @{})
+  (def data (pattern :data))
+  (case (pattern :type)
+    # always match
+    :placeholder {:success true :ctx ctx}
+    :ignored {:success true :ctx ctx}
+    :word (match-word 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: tuples, lists, dicts
+    # TODO: string-patterns
+    # TODO: typed
+  )
+)
+
+(defn- lett [ast ctx]
+  (def [patt expr] (ast :data))
+  (def value (interpret expr ctx))
+  (def match? (match-pattern expr value))
+  (if match?
+    (do
+    
+    )
+    (error {:node ast :msg (string "could not match " (stringify value) " with " )})
+  )
+)
+
+(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)))
+  (case type
+    :nil ""
+    :number (string value)
+    :bool (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))
@@ -8,25 +109,109 @@
     (interpret then ctx)
     (interpret else ctx)))
 
-(defn- script [ast ctx]
-  (print "interpreting script")
-  (def lines (ast :data))
-  (var result nil)
-  (each line lines
-    (print "interpreting script line")
-    (set result (interpret line ctx)))
+(defn- whenn [ast ctx]
+  (def clauses (ast :data))
+  (var result :^nothing)
+  (each clause clauses
+    (def [lhs rhs] clause)
+    (when (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 ast node " (ast :type))
+  (print "interpreting node " (ast :type))
   (case (ast :type)
     :nil nil
     :number (ast :data)
     :bool (ast :data)
     :string (ast :data)
+    :interpolated (interpolated ast ctx)
     :keyword (ast :data)
     :if (iff ast ctx)
-    :script (script ast ctx)))
+    :block (block ast ctx)
+    :word (word ast ctx)
+    :tuple (tup ast ctx)
+    :list (list ast ctx)
+    :set (sett ast ctx)
+    :dict (dict ast ctx)
+    :when (whenn ast ctx)
+    :ref (ref ast ctx)
+    :script (script ast ctx)
+    :panic (panic ast ctx)
+
+    :let (lett ast ctx)
+    ))
 
 (set interpret interpret*)
 
@@ -42,13 +227,14 @@
   (def scanned (s/scan source))
   (def parsed (p/parse scanned))
   (def validated (v/valid parsed))
-  (pp parsed)
   (interpret (parsed :ast) @{}))
 
-
 (do 
 (set source `
-if false then :bar else :baz
+when {
+  3 -> :foo
+  true -> :bar
+}
 `)
 (run)
 )
diff --git a/janet/validate.janet b/janet/validate.janet
index a5ef215..0e9a7c6 100644
--- a/janet/validate.janet
+++ b/janet/validate.janet
@@ -4,6 +4,7 @@
 
 Tracking here, before I start writing this code, the kinds of validation we're hoping to accomplish:
 
+* [ ] validate `with` forms
 * [ ] first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
  - [ ] accept pkg-kws
 * [x] `loop` form arity checking