2big commit: stand up fns, definitions and calls, lots of bugfixes

janet/interpreter.janet

@@ -4,8 +4,10 @@
 (var stringify nil)
 (var match-pattern nil)
 
+(defn- todo [msg] (error (string "not yet implemented: " msg)))
+
 (defn- ltype [value]
-  (def typed? (when (table? value) (:^type value)))
+  (def typed? (when (dictionary? value) (value :^type)))
   (def the-type (if typed? typed? (type value)))
   (case the-type
     :boolean :bool
@@ -43,6 +45,10 @@
   (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?
@@ -128,6 +134,8 @@
     (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)
@@ -149,7 +157,8 @@
     # TODO: lists, dicts
     :tuple (match-tuple pattern value ctx)
     :list (match-list pattern value ctx)
-    # TODO: string-patterns
+    :dict (match-dict pattern value ctx)
+  
     :interpolated (match-string pattern value ctx)
 
     :typed (typed pattern value ctx)
@@ -164,57 +173,55 @@
   (if (match? :success)
     (do
       (merge-into ctx (match? :ctx))
-      (print "new ctx:")
-      (pp ctx)
       value)
-    # TODO: represent patterns textually in errors
+    (error {:node ast :value value :msg "no match"})))
-    (error {:node ast 
-      :msg (string "could not match " (stringify value))})))
 
 (defn- matchh [ast ctx]
   (def [to-match clauses] (ast :data))
   (def value (interpret to-match ctx))
-  (var result :^nothing)
+  (def len (length clauses))
-  (each clause 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)
-    (print "matching ")
+    (def match? (match-pattern patt value @{:^parent ctx}))
-    (pp patt)
+    (when (not (match? :success)) 
-    (def match? (match-pattern patt value))
+      (break (match-fn (inc i) value ctx)))
-    (when (match? :success)
+    (def body-ctx (match? :ctx))
-      (def inner-ctx (match? :ctx))
+    (def guard? (if guard
-      (def guard? (if (bool guard)
+      (bool (interpret guard body-ctx)) true))
-        (interpret guard inner-ctx) true))
+    (when (not guard?) 
-      (when guard?
+      (break (match-fn (inc i) value ctx)))
-        (set result (interpret expr inner-ctx))
+    (interpret expr body-ctx))
-        (break))))
+  (set (ast :match) match-fn)
-  (if (= result :^nothing)
+  (match-fn 0 value ctx))
-    (error {:node ast :value value :msg "no match"})
-    result))
 
 (defn- script [ast ctx]
   (def lines (ast :data))
-  (var result nil)
+  (def last-line (last lines))
-  (each line lines
+  (for i 0 (-> lines length dec) 
-    (set result (interpret line ctx)))
+    (interpret (lines i) ctx))
-  result)
+  (interpret last-line ctx))
 
 (defn- block [ast parent]
   (def lines (ast :data))
-  (var result nil)
+  (def last-line (last lines))
   (def ctx @{:^parent parent})
-  (each line lines
+  (for i 0 (-> lines length dec)
-    (set result (interpret line ctx)))
+    (interpret (lines i) ctx))
-  result)
+  (interpret last-line ctx))
 
 (defn- dict-str [dict]
   (string/join 
     (map 
       (fn [[k v]] (string (stringify k) " " (stringify v))) 
-      dict)
+      (pairs dict))
     ", "))
 
 (defn- stringify* [value]
-  (def typed? (when (table? value) (:^type value)))
+  (def typed? (when (dictionary? value) (value :^type)))
   (def type (if typed? typed? (type value)))
   (print "stringifying " (string value))
   (case type
@@ -238,22 +245,21 @@
 
 (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))
-  (each term terms (pp term))
+  (def interpolations (map (to_string ctx) terms))
-  (def interpolations
-    (map (fn [x]
-      (if (stringish? x) x (stringify (interpret x 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)
@@ -267,15 +273,23 @@
   result)
 
 (defn- word [ast ctx]
-  (def name (ast :data))
+  (resolve-name (ast :data) ctx))
-  (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))
+  [;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))
@@ -312,6 +326,10 @@
         (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))))
@@ -334,6 +352,79 @@
   (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)
@@ -343,9 +434,11 @@
     :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)
@@ -370,10 +463,13 @@
     # :with (withh ast ctx)
 
     # functions
-    # :fn (fnn ast ctx)
+    :fn (fnn ast ctx)
 
     # synthetic
-    # :synthetic (synthetic ast ctx)
+    :synthetic (synthetic ast ctx)
+
+    # do
+    :do (doo ast ctx)
 
     ))
 
@@ -396,6 +492,8 @@
   (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!: " 
@@ -404,8 +502,10 @@
 
 (do 
 (set source `
-let verb = "love"
+fn foo () -> :foo
-"{verb}"
+let bar = #{foo}
+bar :foo ()
 `)
-(run)
+(def result (run))
 )
+

janet/parser.janet

@@ -157,6 +157,12 @@
  {:type :keyword :data (curr :literal) :token curr}
  )
 
+(defn- kw-only [parser]
+ (expect parser :keyword)
+ (def curr (-> parser current))
+ (advance parser)
+ {:type :keyword :data (curr :literal) :token curr})
+
 (defn- nill [parser]
  (expect parser :nil)
  (def curr (current parser))
@@ -308,17 +314,17 @@
 (defrec synthetic [parser]
  (print "parsing synthetic")
  (def origin (current parser))
- (def ast {:type :synthetic :data @[(synth-root parser)] :token origin})
+ # (def ast {:type :synthetic :data @[(synth-root parser)] :token origin})
+ (def terms @[(synth-root parser)])
  (while (has-value? sequels (-> parser current type))
   (def term 
    (case (-> parser current type)
     :lparen (args parser)
-    :keyword (kw parser)
+    :keyword (kw-only parser)
   ))
-  (array/push (ast :data) term)
+  (array/push terms term)
- )
- ast
  )
+ {:type :synthetic :data [;terms] :token origin})
 
 # collections
 (defn- tup [parser]
@@ -399,9 +405,13 @@
   (def origin (current parser))
   (def term (case (type origin)
    :splat {:type :splat :data (capture word-only (advance parser)) :token origin}
-   :word (try (word-only parser) ([e] e))
+   :word (do
+    (def value (capture word-only parser))
+    (def key {:type :keyword :data (keyword (value :data))
+     :token origin})
+    {:type :pair :data [key value] :token origin})
    :keyword (do
-    (def key (try (kw parser) ([e] e)))
+    (def key (capture kw parser))
     (def value (capture nonbinding parser))
     {:type :pair :data [key value] :token origin})
    (try (panic parser (string "expected dict term, got " (type origin))) ([e] e))
@@ -636,7 +646,7 @@
      (error {:type :error :token open-brace :msg "unclosed brace"}))
     (array/push clauses (match-clause parser)))
    (advance parser)
-   {:type :match :data [to-match clauses] :token origin})
+   @{:type :match :data [to-match clauses] :token origin})
   ([err] err)))
 
 # {pattern} = {nonbinding} {terminators}
@@ -1096,17 +1106,18 @@
 
 (do
 # (comment
-(def source `
+(def source `a :b :c
-"{bar}{quux}"
 `)
 (def scanned (s/scan source))
 (print "\n***NEW PARSE***\n")
 (def a-parser (new-parser scanned))
-(def parsed (interpolated a-parser))
+(def parsed (expr a-parser))
 
 # (print (pp-ast parsed))
-(pp scanned)
+# (pp scanned)
-(pp parsed)
+# (pp parsed)
+(def cleaned (get-in parsed [:data 2]))
+(pp cleaned)
 )
 
 

janet/scanner.janet

@@ -272,7 +272,7 @@
       "-" (cond
            (= next ">") (add-token (advance scanner) :arrow)
            (digit? next) (add-number char scanner)
-           :else (add-error scanner (string "Expected -> or negative number after `-`. Got `" char next "`")))
+           :else (add-error scanner (string "Expected > or negative number after `-`. Got `" char next "`")))
 
       ## dict #{
       "#" (if (= next "{")

janet/validate.janet

@@ -4,6 +4,7 @@
 
 Tracking here, before I start writing this code, the kinds of validation we're hoping to accomplish:
 
+* [ ] ensure called keywords are only called w/ one arg
 * [ ] validate `with` forms
 * [ ] first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
  - [ ] accept pkg-kws