2 files changed, 58 insertions(+), 27 deletions(-)

M fugue.janet
M test/fugue.janet

@@ 285,7 285,7 @@
   Object prototype definition.
 
   ## Usage
-  
+
   `name` should be any symbol. The resulting prototype will be
   named after it.
 


@@ 333,16 333,16 @@
   and arrays will be shared amongst all instances. In cases where you
   want to insert a new term for each new instance, use the `_init`
   method to put a value at that field.
-  
+
   If `fields` is of an odd length, the last element will be treated as
   a prototype attributes struct. There is currently one valid prototype attribute:
 
   - `:constructor` : Set the name of the defined function that
-    calls `:new`. If false, no additional constructor will be
-    defined. By default, will be set to `new-<prototype name>`.
-  
+  calls `:new`. If false, no additional constructor will be
+  defined. By default, will be set to `new-<prototype name>`.
+
   ---
-  
+
   An example usage:
 
   ```


@@ 455,7 455,7 @@
   `put` ing a function directly into a prototype.
 
   Defines a few symbols for reference in the body of the method.
-  
+
   - `__parent` - Bound to the parent of `proto`.
   - `__super` - Bound to the method at `name` within `__parent`.
   ```


@@ 488,12 488,16 @@
         #     [:_ :_]
         (sort . >)))
 
+(defn- compile-matcher
+  [sym]
+  (eval ~(fn [x] (match x ,sym true))))
+
 (defn- replace-placeholder-symbols
   [types]
   (defn f [sym]
-    (case sym
-      '_ nil
-      :_ nil
+    (cond
+      (or (= '_ sym) (= :_ sym)) nil
+      (or (tuple? sym) (struct? sym)) (compile-matcher sym)
       (let [evaled (eval sym)]
         (if (not (or (table? evaled) (keyword? evaled)))
           (errorf `Multimethod type error. Expected keyword or prototype, got:


@@ 561,28 565,42 @@
       (while true
         (set kk (next args kk))
         (if (= nil kk) (break))
+
         (set vk (next arg-types vk))
         (if (= nil vk) (break))
+
         (unless (or (= (arg-types vk) nil)
+                    (and (function? (arg-types vk))
+                         ((arg-types vk) (args kk)))
                     (= (get-type-or-proto (args kk)) (arg-types vk)))
           (set res false)
           (break)))
+
       res)))
 
 (defn- make-case
-  [args body]
-  (eval ~(fn ,args ,;body)))
+  [multi-types args body]
+  (let [destructurable @[]]
+    (each [type arg] (map tuple multi-types args)
+      (cond
+        (struct? type) (array/concat destructurable @[type arg])
+        (tuple? type) (array/concat destructurable @[(first type) arg])))
+    (eval ~(fn multimethod-case
+             ,args
+             (let ,destructurable
+               ,;body)))))
 
 (defn- construct-cond
   "Build main function logic of multimethod"
   [name cases args-symbol]
   (defn cond-case
-    [[case-types case]]
+    [[case-types case-fn]]
     ~[(,multimethod-types-match? ,args-symbol ',case-types)
-      (,case ;,args-symbol)])
+      (,case-fn ;,args-symbol)])
 
   (let [body (mapcat cond-case cases)
-        err-msg (string/format "could not apply multimethod %s to args %%q" name)]
+        err-msg (string/format "could not apply multimethod %s to args %%q"
+                               name)]
     ~(cond ,;body (,errorf ,err-msg ,args-symbol))))
 
 (defn- make-docstring


@@ 643,8 661,8 @@
   "hello 42"
   repl:5:> (cat 42 "hello")
   error: could not apply multimethod <function cat> to args (42 "hello")
-    in cat [repl] on line 2, column 1
-    in _thunk [repl] (tailcall) on line 5, column 1
+  in cat [repl] on line 2, column 1
+  in _thunk [repl] (tailcall) on line 5, column 1
   ```
 
   Defining a multimethod with the signature `[:string :_]` will match


@@ 673,7 691,7 @@
   # current file with the name of the function.
   (let [cases-key (keyword (dyn :current-file) "-" name)]
     (set-multi-default cases-key)
-    (put-multi-case cases-key multi-types (make-case args body))
+    (put-multi-case cases-key multi-types (make-case multi-types args body))
 
     (with-syms [args]
       (let [cases (get-multi-cases cases-key)


@@ 724,7 742,7 @@
   ```
   [multi multi-types args & body]
   (let [ref (and (dyn multi) (in (dyn multi) :ref))]
-    (put-var-case ref multi-types (make-case args body))
+    (put-var-case ref multi-types (make-case multi-types args body))
 
     (with-syms [args]
       (let [cases (get-var-cases ref)


@@ 744,7 762,7 @@
           (unless (index-of field-name fields)
             (errorf `Encountered field reference %q for prototype %q;
 
-                   Expected one of: %q`
+                     Expected one of: %q`
                     sym
                     proto-name
                     fields))


@@ 780,7 798,7 @@
   `obj`.
 
   Returns `obj`.
-  
+
   ---
 
   Example :


@@ 788,9 806,9 @@
   ```
   repl:2:> (defproto Foo nil name {:default "Jane Doe"})
   repl:4:> (with-slots Foo (new-Foo)
-             (set (@ name) "Cosmo Kramer")
-             (print (@ name))
-             (print (Foo? @)))
+  (set (@ name) "Cosmo Kramer")
+  (print (@ name))
+  (print (Foo? @)))
   Cosmo Kramer
   true
   @Foo{:_meta @{:object-type :instance} :name "Cosmo Kramer"}


@@ 841,9 859,9 @@
   Prototype-aware version of `match`. Introduces one new case form:
 
   - `(@ <prototype-name> <dictionary>)`: Will pattern match against an
-    instance of `prototype-name`. Additionally, will validate at
-    compile-time that every key in `dictionary` is a field that's
-    present on the specified prototype. 
+  instance of `prototype-name`. Additionally, will validate at
+  compile-time that every key in `dictionary` is a field that's
+  present on the specified prototype. 
   ```
   [x & cases]
   (defn transform

@@ 499,4 499,17 @@
   (is (= "Matcher!" (try-match (new-MyMatcher :name "Matcher"))))
   (is (= "Non-Matcher." (try-match "Non-Matcher"))))
 
+(deftest matching-multis
+  (fugue/defmulti with-matching 
+                  [{:magic-key z}] [x] 
+                  (inc (x :magic-key)))
+
+  (fugue/declare-open-multi open-with-matching)
+  (fugue/extend-multi open-with-matching 
+                      [{:magicer-key z}] [x] 
+                      (inc (x :magicer-key)))
+  
+  (is (= 1 (with-matching {:magic-key 0})))
+  (is (= 1 (open-with-matching {:magicer-key 0}))))
+
 (run-tests!)