base.match: predicate fn matching

2 files changed, 172 insertions, 14 deletions

diff --git a/alv/base/match.moon b/alv/base/match.moon
index 303537c..34b8e14 100644
--- a/alv/base/match.moon
+++ b/alv/base/match.moon
@@ -88,33 +88,63 @@ class Pattern
 
 --- Base Result Pattern.
 --
--- When instantiated with `type`, only succeeds for `Result`s whose value and
--- meta types match.
+-- When instantiated with `type`, only succeeds for `Result`s whose type and
+-- metatypes match.
 --
 -- Otherwise, matches Streams based only on `metatype` for the first match, but
 -- using both afterwards (recall mode).
 --
 -- @function Type
--- @tparam string metatype `'~', '!' or '='
+-- @tparam ?string metatype `'~', '!' or '='
 -- @tparam ?string type type name
 class Type extends Pattern
   new: (@metatype, @type, @recall=false) =>
 
   casts = { '!!': true, '==': true, '~~': true, '~=': true }
   capture: (seq, i) =>
-    return unless seq[i]
-    type, mt = seq[i]\type!, seq[i]\metatype!
+    elem = seq[i]
+    return unless elem
+
+    typ, mt = elem\type!, elem\metatype!
 
     if @metatype and not casts[@metatype .. mt]
       return
 
-    match = if @type then type == @type else @remember type
+    match = if @type then typ == @type else @remember typ
     if match
-      1, seq[i]
+      1, elem
 
   __call: => @@ @metatype, @type, true
   __tostring: => "#{@type or 'any'}#{@metatype or ''}"
 
+--- Predicate function Pattern.
+--
+-- Only succeeds for `Result`s whose metatype matches and for which the
+-- predicate function returns true.
+--
+-- @function Predicate
+-- @tparam ?string metatype `'~', '!' or '='
+-- @tparam function predicate gets `type` as an argument
+-- @tparam string name printable alias for error reporting
+class Predicate extends Pattern
+  new: (@metatype, @fn, @name, @recall=false) =>
+
+  casts = { '!!': true, '==': true, '~~': true, '~=': true }
+  capture: (seq, i) =>
+    elem = seq[i]
+    return unless elem
+
+    typ, mt = elem\type!, elem\metatype!
+
+    if @metatype and not casts[@metatype .. mt]
+      return
+
+    if (@.fn typ) and @remember typ
+      1, elem
+
+  __call: => @@ @metatype, @fn, @name, true
+  __tostring: => "#{@name or '[predicate]'}#{@metatype or ''}"
+
 --- Repeat a pattern.
 --
 -- Matches a given `inner` pattern as many times as possible, within the given
@@ -207,7 +237,6 @@ class Sequence extends Pattern
 --
 -- @function Choice
 -- @tparam {Pattern,...} elements the inner patterns
--- @tparam ?{string,...} keys the keys to use when capturing matches
 class Choice extends Pattern
   new: (@elements, @recall=false) =>
 
@@ -261,11 +290,13 @@ class Optional extends Pattern
 
 --- `Type` shorthands for matching `Constant`s.
 --
--- Call or index with a string to obtain an `Type` instance.
+-- Call or index with a type or string to obtain an `Type` instance.
+-- Call with a function and name to obtain a `Predicate` instance.
 -- Call to obtain a wildcard pattern.
 --
 --     const.bang, const.str, const.num
 --     const['midi/message'], const(Primitive 'midi/message')
+--     const(function(typ) return typ.__class == Array end, "array")
 --     const()
 --
 -- @table const
@@ -274,16 +305,22 @@ const = setmetatable {}, {
     with v = Type '=', T[key]
       @[key] = v
 
-  __call: (...) => Type '=', ...
+  __call: (t, ...) =>
+    if 'function' == type t
+      Predicate '=', t, ...
+    else
+      Type '=', t, ...
 }
 
 --- `Type` shorthands for matching `ValueStream`s and `Constant`s.
 --
 -- Call or index with a type or string to obtain a `Type` instance.
+-- Call with a function and name to obtain a `Predicate` instance.
 -- Call to obtain a wildcard pattern.
 --
 --     sig.str, sig.num
 --     sig['vec3'], sig(T.vec3)
+--     sig(function(typ) return typ.__class == Array end, "array")
 --     sig()
 --
 -- @table sig
@@ -292,16 +329,22 @@ sig = setmetatable {}, {
     with v = Type '~', T[key]
       @[key] = v
 
-  __call: (...) => Type '~', ...
+  __call: (t, ...) =>
+    if 'function' == type t
+      Predicate '~', t, ...
+    else
+      Type '~', t, ...
 }
 
 --- `Type` shorthands for matching `EvtStream`s.
 --
 -- Call or index with a type or string to obtain an `Type` instance.
+-- Call with a function and name to obtain a `Predicate` instance.
 -- Call to obtain a wildcard pattern.
 --
 --     evt.bang, evt.str, evt.num
 --     evt['midi/message'], evt(Primitive 'midi/message')
+--     evt(function(typ) return typ.__class == Struct end, "struct")
 --     evt()
 --
 -- @table evt
@@ -310,16 +353,22 @@ evt = setmetatable {}, {
     with v = Type '!', T[key]
       @[key] = v
 
-  __call: (...) => Type '!', ...
+  __call: (t, ...) =>
+    if 'function' == type t
+      Predicate '!', t, ...
+    else
+      Type '!', t, ...
 }
 
 --- `Type` shorthands for matching any `Result`s.
 --
 -- Call or index with a type or string to obtain an `Type` instance.
+-- Call with a function and name to obtain a `Predicate` instance.
 -- Call to obtain a wildcard pattern.
 --
 --     any.bang, any.str, any.num
 --     any['midi/message'], any(Primitive 'midi/message')
+--     any(function(typ) return typ.__class == Array end, "array")
 --     any()
 --
 -- @table any
@@ -328,10 +377,14 @@ any = setmetatable {}, {
     with v = Type nil, T[key]
       @[key] = v
 
-  __call: (...) => Type nil, ...
+  __call: (t, ...) =>
+    if 'function' == type t
+      Predicate nil, t, ...
+    else
+      Type nil, t, ...
 }
 
 {
-  :Type, :Repeat, :Sequence, :Choice, :Optional
+  :Type, :Predicate, :Repeat, :Sequence, :Choice, :Optional
   :const, :sig, :evt, :any
 }
diff --git a/spec/internal/match_spec.moon b/spec/internal/match_spec.moon
index b9d5ef6..83a208f 100644
--- a/spec/internal/match_spec.moon
+++ b/spec/internal/match_spec.moon
@@ -29,6 +29,8 @@ describe 'sig and evt', ->
       assert.has.error -> const!\match { num }
       assert.has.error -> evt!\match { str }
       assert.has.error -> evt!\match { num }
+      assert.is.equal str, any!\match { str }
+      assert.is.equal num, any!\match { num }
 
       str = mk_evt 'str'
       num = mk_evt 'num'
@@ -38,6 +40,10 @@ describe 'sig and evt', ->
       assert.has.error -> const!\match { num }
       assert.is.equal str, evt!\match { str }
       assert.is.equal num, evt!\match { num }
+      assert.is.equal str, any!\match { str }
+      assert.is.equal num, any!\match { num }
+      assert.is.equal str, any!\match { str }
+      assert.is.equal num, any!\match { num }
 
       str = mk_const 'str'
       num = mk_const 'num'
@@ -47,12 +53,18 @@ describe 'sig and evt', ->
       assert.is.equal num, const!\match { num }
       assert.has.error -> evt!\match { str }
       assert.has.error -> evt!\match { num }
+      assert.is.equal str, any!\match { str }
+      assert.is.equal num, any!\match { num }
+      assert.is.equal str, any!\match { str }
+      assert.is.equal num, any!\match { num }
 
     it 'can recall the type', ->
       value = sig!!
       event = evt!!
+      thing = any!!
       two_equal_values = value + value
       two_equal_events = event + event
+      two_equal_things = thing + thing
 
       str1 = mk_val 'str'
       str2 = mk_val 'str'
@@ -60,8 +72,13 @@ describe 'sig and evt', ->
       assert.is.same { str1, str2 }, two_equal_values\match { str1, str2 }
       assert.is.same { str2, str1 }, two_equal_values\match { str2, str1 }
       assert.is.same { num, num }, two_equal_values\match { num, num }
+      assert.is.same { str1, str2 }, two_equal_things\match { str1, str2 }
+      assert.is.same { str2, str1 }, two_equal_things\match { str2, str1 }
+      assert.is.same { num, num }, two_equal_things\match { num, num }
       assert.has.error -> two_equal_values\match { str1, num }
       assert.has.error -> two_equal_values\match { num, str2 }
+      assert.has.error -> two_equal_things\match { str1, num }
+      assert.has.error -> two_equal_things\match { num, str2 }
       assert.has.error -> two_equal_events\match { str1, str2 }
 
       str1 = mk_evt 'str'
@@ -70,14 +87,20 @@ describe 'sig and evt', ->
       assert.is.same { str1, str2 }, two_equal_events\match { str1, str2 }
       assert.is.same { str2, str1 }, two_equal_events\match { str2, str1 }
       assert.is.same { num, num }, two_equal_events\match { num, num }
+      assert.is.same { str1, str2 }, two_equal_things\match { str1, str2 }
+      assert.is.same { str2, str1 }, two_equal_things\match { str2, str1 }
+      assert.is.same { num, num }, two_equal_things\match { num, num }
       assert.has.error -> two_equal_events\match { str1, num }
       assert.has.error -> two_equal_events\match { num, str2 }
+      assert.has.error -> two_equal_things\match { str1, num }
+      assert.has.error -> two_equal_things\match { num, str2 }
       assert.has.error -> two_equal_values\match { str1, str2 }
 
     it 'stringifies well', ->
       assert.is.equal 'any=', tostring const!
       assert.is.equal 'any!', tostring evt!
       assert.is.equal 'any~', tostring sig!
+      assert.is.equal 'any', tostring any!
 
   describe 'typed shorthand', ->
     it 'matches by metatype', ->
@@ -89,6 +112,8 @@ describe 'sig and evt', ->
       assert.has.error -> const.num\match { num }
       assert.has.error -> evt.str\match { str }
       assert.has.error -> evt.num\match { num }
+      assert.is.equal str, any.str\match { str }
+      assert.is.equal num, any.num\match { num }
 
       str = mk_evt 'str'
       num = mk_evt 'num'
@@ -98,6 +123,8 @@ describe 'sig and evt', ->
       assert.has.error -> const.num\match { num }
       assert.is.equal str, evt.str\match { str }
       assert.is.equal num, evt.num\match { num }
+      assert.is.equal str, any.str\match { str }
+      assert.is.equal num, any.num\match { num }
 
       str = mk_const 'str'
       num = mk_const 'num'
@@ -107,6 +134,8 @@ describe 'sig and evt', ->
       assert.is.equal num, const.num\match { num }
       assert.has.error -> evt.str\match { str }
       assert.has.error -> evt.num\match { num }
+      assert.is.equal str, any.str\match { str }
+      assert.is.equal num, any.num\match { num }
 
     it 'matches by type', ->
       str = mk_const 'str'
@@ -144,6 +173,82 @@ describe 'sig and evt', ->
       assert.is.equal 'str=', tostring const.str
       assert.is.equal 'num=', tostring const.num
 
+  describe 'predicate shorthand', ->
+    sig_str = sig ((typ) -> typ == T.str), "str"
+    sig_num = sig ((typ) -> typ == T.num), "num"
+    const_str = const ((typ) -> typ == T.str), "str"
+    const_num = const ((typ) -> typ == T.num), "num"
+    evt_str = evt ((typ) -> typ == T.str), "str"
+    evt_num = evt ((typ) -> typ == T.num), "num"
+    any_str = any ((typ) -> typ == T.str), "str"
+    any_num = any ((typ) -> typ == T.num), "num"
+
+    it 'matches by metatype', ->
+      str = mk_val 'str'
+      num = mk_val 'num'
+      assert.is.equal str, sig_str\match { str }
+      assert.is.equal num, sig_num\match { num }
+      assert.has.error -> const_str\match { str }
+      assert.has.error -> const_num\match { num }
+      assert.has.error -> evt_str\match { str }
+      assert.has.error -> evt_num\match { num }
+      assert.is.equal str, any_str\match { str }
+      assert.is.equal num, any_num\match { num }
+
+      str = mk_evt 'str'
+      num = mk_evt 'num'
+      assert.has.error -> sig_str\match { str }
+      assert.has.error -> sig_num\match { num }
+      assert.has.error -> const_str\match { str }
+      assert.has.error -> const_num\match { num }
+      assert.is.equal str, evt_str\match { str }
+      assert.is.equal num, evt_num\match { num }
+      assert.is.equal str, any_str\match { str }
+      assert.is.equal num, any_num\match { num }
+
+      str = mk_const 'str'
+      num = mk_const 'num'
+      assert.is.equal str, sig_str\match { str }
+      assert.is.equal num, sig_num\match { num }
+      assert.is.equal str, const_str\match { str }
+      assert.is.equal num, const_num\match { num }
+      assert.has.error -> evt_str\match { str }
+      assert.has.error -> evt_num\match { num }
+      assert.is.equal str, any_str\match { str }
+      assert.is.equal num, any_num\match { num }
+
+    it 'matches by type', ->
+      str = mk_const 'str'
+      num = mk_const 'num'
+      assert.is.equal str, sig_str\match { str }
+      assert.is.equal num, sig_num\match { num }
+      assert.is.equal str, const_str\match { str }
+      assert.is.equal num, const_num\match { num }
+      assert.is.equal str, any_str\match { str }
+      assert.is.equal num, any_num\match { num }
+      assert.has.error -> sig_num\match { str }
+      assert.has.error -> sig_str\match { num }
+
+      str = mk_val 'str'
+      num = mk_val 'num'
+      assert.is.equal str, sig_str\match { str }
+      assert.is.equal num, sig_num\match { num }
+      assert.has.error -> const_num\match { str }
+      assert.has.error -> const_str\match { num }
+      assert.has.error -> sig_num\match { str }
+      assert.has.error -> sig_str\match { num }
+
+      str = mk_evt 'str'
+      num = mk_evt 'num'
+      assert.is.equal str, evt_str\match { str }
+      assert.is.equal num, evt_num\match { num }
+      assert.has.error -> const_num\match { str }
+      assert.has.error -> const_str\match { num }
+      assert.has.error -> evt_num\match { str }
+      assert.has.error -> evt_str\match { num }
+
+      assert.has.error -> any_str\match { num }
+
 describe 'choice', ->
   str = mk_val 'str'
   num = mk_val 'num'