add match exprs

janet/interpreter.janet

@@ -13,6 +13,9 @@
     :table :dict
     the-type))
 
+(defn- bool [value]
+  (if (= value :^nil nil) value))
+
 (defn- resolve-name [name ctx]
   (print "resolving " name " in:")
   (pp ctx)
@@ -72,6 +75,45 @@
     {: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 tuple lenghts")
+      (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-pattern* [pattern value &opt ctx]
   (print "in match-pattern, matching " value " with:")
   (pp pattern)
@@ -92,8 +134,9 @@
 
     # TODO: lists, dicts
     :tuple (match-tuple pattern value ctx)
+    :list (match-list pattern value ctx)
     # TODO: string-patterns
-    # TODO: typed
+
     :typed (typed pattern value ctx)
   ))
 
@@ -113,6 +156,26 @@
     (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)
+  (each clause clauses
+    (def [patt guard expr] clause)
+    (print "matching ")
+    (pp patt)
+    (def match? (match-pattern patt value))
+    (when (match? :success)
+      (def inner-ctx (match? :ctx))
+      (def guard? (if (bool guard)
+        (interpret guard inner-ctx) true))
+      (when guard?
+        (set result (interpret expr inner-ctx))
+        (break))))
+  (if (= result :^nothing)
+    (error {:node ast :value value :msg "no match"})
+    result))
+
 (defn- script [ast ctx]
   (def lines (ast :data))
   (var result nil)
@@ -128,7 +191,6 @@
     (set result (interpret line ctx)))
   result)
 
-
 (defn- dict-str [dict]
   (string/join 
     (map 
@@ -154,7 +216,7 @@
     :set
       (string/join (map stringify (keys value)) ", ")
     :ref (stringify (value :^value))
-    # XXX: pkg, fn, 
+    # XXX: pkg, fn 
   ))
 
 (set stringify stringify*)
@@ -167,9 +229,10 @@
       terms))
   (string/join interpolations))
 
+
 (defn- iff [ast ctx]
   (def [condition then else] (ast :data))
-  (if (interpret condition ctx)
+  (if (bool (interpret condition ctx))
     (interpret then ctx)
     (interpret else ctx)))
 
@@ -178,7 +241,7 @@
   (var result :^nothing)
   (each clause clauses
     (def [lhs rhs] clause)
-    (when (interpret lhs ctx)
+    (when (bool (interpret lhs ctx))
       (set result (interpret rhs ctx))
       (break)))
   (when (= result :^nothing)
@@ -257,7 +320,7 @@
   (print "interpreting node " (ast :type))
   (case (ast :type)
     # literals
-    :nil nil
+    :nil :^nil
     :number (ast :data)
     :bool (ast :data)
     :string (ast :data)
@@ -280,9 +343,19 @@
     :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)
 
     ))
 
@@ -296,10 +369,15 @@
 
 (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)))
   # (interpret (parsed :ast) @{})
   (try (interpret (parsed :ast) @{})
     ([e] (print "Ludus panicked!: " 
@@ -308,7 +386,10 @@
 
 (do 
 (set source `
-
+match "foo" with {
+  "f{ooo}o" -> ooo
+  _ -> :nope
+}
 `)
 (run)
 )

janet/parser.janet

@@ -228,7 +228,7 @@
    (array/push data curr)
    (def interpolated (map scan-interpolations data))
    (advance parser)
-   (def ast {:type :interpolated :data interpolated :token origin})
+   (def ast @{:type :interpolated :data interpolated :token origin})
    (if (some is-error? interpolated) 
     (do 
      (def err {:type :error :msg "bad interpolated string" :data ast :token origin})
@@ -620,19 +620,23 @@
 (defn- matchh [parser]
  (def origin (current parser))
  (def ast {:type :match :data @[] :token origin})
+ (var to-match nil)
+ (def clauses @[])
  (expect parser :match)
  (advance parser)
  (try
   (do
-   (simple parser)
+   (set to-match (simple parser))
    (expect parser :with) (advance parser)
+   (def open-brace (current parser))
    (expect parser :lbrace) (advance parser)
    (accept-many parser :newline)
    (while (not (check parser :rbrace))
-    (when (check parser :eof) (error {:type :error :token origin :data ast :msg "unclosed brace"}))
-    (array/push (ast :data) (match-clause parser)))
+    (when (check parser :eof) 
+     (error {:type :error :token open-brace :msg "unclosed brace"}))
+    (array/push clauses (match-clause parser)))
    (advance parser)
-   ast)
+   {:type :match :data [to-match clauses] :token origin})
   ([err] err)))
 
 # {pattern} = {nonbinding} {terminators}
@@ -1090,15 +1094,15 @@
 )
 
 
-# (do
-(comment
+(do
+# (comment
 (def source `
-loop (1, 2) with (x, y) -> :bar
+"{bar}{quux}"
 `)
 (def scanned (s/scan source))
 (print "\n***NEW PARSE***\n")
 (def a-parser (new-parser scanned))
-(def parsed (toplevel a-parser))
+(def parsed (interpolated a-parser))
 
 # (print (pp-ast parsed))
 (pp scanned)

janet/scanner.janet

@@ -327,7 +327,7 @@
     (if (at-end? scanner)
       (let [scanner (add-token (add-token scanner :break) :eof)]
         {:tokens (get scanner :tokens)
-         :errors (get scanner :errors)})
+         :errors (get scanner :errors [])})
       (recur (-> scanner (scan-token) (next-token)))))
   (recur (new-scanner source input)))
 

janet/validate.janet

@@ -7,6 +7,8 @@ Tracking here, before I start writing this code, the kinds of validation we're h
 * [ ] validate `with` forms
 * [ ] first-level property access with pkg, e.g. `Foo :bar`--bar must be on Foo
  - [ ] accept pkg-kws
+* [x] compile string-patterns
+* [ ] validate dict patterns
 * [x] `loop` form arity checking
 * [x] arity checking of explicit named function calls
 * [x] flag tail calls
@@ -182,6 +184,31 @@ Imports are for a later iteration of Ludus:
  (set (validator :ast) word)
  (pattern validator))
 
+(defn- str-pattern [validator]
+ (def ast (validator :ast))
+ (def data (ast :data))
+ (array/pop data)
+ (def grammar @{})
+ (def bindings @[])
+ (var current 0)
+ (each node data
+  (when (not (buffer? node))
+   (set (validator :ast) node)
+   (pattern validator))
+  (if (buffer? node)
+   (set (grammar (keyword current)) (string node)) 
+   (do
+    (set (grammar (keyword current))
+     ~(<- (to ,(keyword (inc current)))))
+    (array/push bindings (node :data))))
+  (set current (inc current)))
+ (def rules (map keyword (range (length grammar))))
+ (set (grammar (keyword current)) -1)
+ (set (grammar :main) ~(sequence ,;rules))
+ (set (ast :grammar) grammar)
+ (set (ast :compiled) (peg/compile grammar))
+ (set (ast :bindings) bindings))
+
 (defn- pattern* [validator]
  (print "PATTERN*")
  (def ast (validator :ast))
@@ -198,6 +225,7 @@ Imports are for a later iteration of Ludus:
    :tuple (simple-coll-pattern validator)
    :splat (splattern validator)
    :typed (typed validator)
+   :interpolated (str-pattern validator)
    )))
 
 (set pattern pattern*)
@@ -207,6 +235,7 @@ Imports are for a later iteration of Ludus:
 (defn- guard [validator])
 
 (defn- match-clauses [validator clauses]
+ (print "validating clauses in match-clauses")
  (each clause clauses
   (def parent (validator :ctx))
   (def ctx @{:^parent parent})
@@ -224,8 +253,15 @@ Imports are for a later iteration of Ludus:
   (set (validator :ctx) parent)))
 
 (defn- matchh [validator]
+ (print "validating in matchh")
  (def ast (validator :ast))
- (match-clauses validator (ast :data))
+ (def [to-match clauses] (ast :data))
+ (print "validating expression:")
+ (pp to-match)
+ (set (validator :ast) to-match)
+ (validate validator)
+ (print "validating clauses")
+ (match-clauses validator clauses)
  validator)
 
 (defn- fnn [validator]
@@ -290,7 +326,6 @@ Imports are for a later iteration of Ludus:
 # * [ ] ensure properties are on pkgs (if *only* pkgs from root)
 (defn- pkg-root [validator])
 
-# * [ ] flag tail calls (where last term is not-partial args)
 (defn- tail-call [validator]
  (def ast (validator :ast))
  (when (ast :partial) (break validator))
@@ -300,8 +335,6 @@ Imports are for a later iteration of Ludus:
  (def args (last data))
  (set (args :tail-call) true))
 
-# * [ ] arity checking if first term is name that resolves to a function and args aren't partial
-# XXX: now just check number of args against arity map
 (defn- check-arity [validator]
  (def ast (validator :ast))
  (when (ast :partial) (break validator))
@@ -348,7 +381,6 @@ Imports are for a later iteration of Ludus:
   (check-arity validator))
  validator)
 
-### XXX: todos from parser
 (defn- pair [validator]
  (def ast (validator :ast))
  (def [k v] (ast :data))
@@ -388,6 +420,7 @@ Imports are for a later iteration of Ludus:
   (validate validator))
  validator)
 
+# XXX: do this!
 (defn- withh [validator])
 
 # XXX: tail calls in last position
@@ -592,8 +625,30 @@ Imports are for a later iteration of Ludus:
 (do
 # (comment
 (def source `
-
+let "{foo}" = "bar"
 `)
 (def scanned (s/scan source))
 (def parsed (p/parse scanned))
-(valid parsed))
+(valid parsed)
+(print "VALIDATED!!")
+(def grammar (get-in parsed [:ast :data 0 :data 0 :grammar]))
+(pp grammar)
+(peg/match grammar "foo"))
+
+(def bar @{
+ :0 "" 
+ :1 '(<- (to :2)) 
+ :2 "" 
+ :main '(sequence :0 :1 :2 -1)
+ })
+
+(peg/match bar "foo")
+
+(def foo @{
+ :0 ""
+ :1 '(<- (to :2))
+ :2 -1
+ :main '(sequence :0 :1 :2)
+})
+
+(peg/match foo "foooooooobar")