3 files changed, 134 insertions(+), 43 deletions(-)

M README.md
M fugue.janet
M test/fugue.janet

@@ 61,7 61,7 @@ be selected for any descendent prototype instances.
 
 ## fugue
 
-[@](#), [Root](#Root), [Root*?](#Root-1), [Root?](#Root-2), [allocate](#allocate), [declare-open-multi](#declare-open-multi), [defgeneric](#defgeneric), [defmethod](#defmethod), [defmulti](#defmulti), [defproto](#defproto), [extend-multi](#extend-multi), [fields](#fields), [get-type-or-proto](#get-type-or-proto), [multimethod-types-match?](#multimethod-types-match), [new-Root](#new-Root), [prototype?](#prototype), [with-slots](#with-slots), [with-slots-as](#with-slots-as)
+[@](#), [Root](#Root), [Root*?](#Root-1), [Root?](#Root-2), [allocate](#allocate), [declare-open-multi](#declare-open-multi), [defgeneric](#defgeneric), [defmethod](#defmethod), [defmulti](#defmulti), [defproto](#defproto), [extend-multi](#extend-multi), [fields](#fields), [get-type-or-proto](#get-type-or-proto), [match](#match), [multimethod-types-match?](#multimethod-types-match), [new-Root](#new-Root), [prototype?](#prototype), [with-slots](#with-slots), [with-slots-as](#with-slots-as)
 
 ## @
 


@@ 81,10 81,9 @@ Accepts two forms:
 `(@ SomePrototype some-object :some-field)` - Asserts (as above) at
 compile time that `some-field` is defined on `SomePrototype`; at
 runtime, checks that `some-object` is a descendent of
-`SomePrototype` and if so, translates to `(some-object
-:some-field)`.
+`SomePrototype` and if so, translates to `(some-object :some-field)`.
 
-[1]: fugue.janet#L754
+[1]: fugue.janet#L797
 
 ## Root
 


@@ 96,7 95,7 @@ runtime, checks that `some-object` is a descendent of
 
 Root of the Fugue object hierarchy.
 
-[2]: fugue.janet#L15
+[2]: fugue.janet#L40
 
 ## Root*?
 


@@ 137,7 136,7 @@ specific prototype for this key, then `fugue/allocate` will put `value`
 at `key` in the appropriate prototype, and it will be inherited by
 all descendents of that prototype.
 
-[5]: fugue.janet#L335
+[5]: fugue.janet#L362
 
 ## declare-open-multi
 


@@ 153,14 152,14 @@ Extending an open multimethod (see `extend-multi`) from any other
 environment makes the case extension available wherever the
 multimethod has been imported.
 
-[6]: fugue.janet#L640
+[6]: fugue.janet#L676
 
 ## defgeneric
 
 **macro**  | [source][7]
 
 ```janet
-(defgeneric name args &opt body)
+(defgeneric name & rest)
 ```
 
 Define a generic function. When this function is called, if the


@@ 168,7 167,7 @@ first argument has a method corresponding to the name of the
 function, call that object 's method with the arguments. Otherwise,
 evaluate `body`.
 
-[7]: fugue.janet#L371
+[7]: fugue.janet#L399
 
 ## defmethod
 


@@ 186,7 185,7 @@ 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`.
 
-[8]: fugue.janet#L382
+[8]: fugue.janet#L417
 
 ## defmulti
 


@@ 258,7 257,7 @@ repl:12:> (cat "hello" 100)
 "hello #100"
 ```
 
-[9]: fugue.janet#L564
+[9]: fugue.janet#L600
 
 ## defproto
 


@@ 340,7 339,7 @@ repl:47:> (speak (:new Pekingese))
 "My name is Fido and I am Extremely Small"
 ```
 
-[10]: fugue.janet#L232
+[10]: fugue.janet#L259
 
 ## extend-multi
 


@@ 358,7 357,7 @@ See that function's documentation for full usage reference.
 Whenever a case is added to `multi`, that case is available
 wherever the multimethod is imported.
 
-[11]: fugue.janet#L656
+[11]: fugue.janet#L692
 
 ## fields
 


@@ 371,7 370,7 @@ wherever the multimethod is imported.
 Return all the defined fields for `obj` and its prototype
 hierarchy.
 
-[12]: fugue.janet#L21
+[12]: fugue.janet#L50
 
 ## get-type-or-proto
 


@@ 384,11 383,28 @@ hierarchy.
 Return the prototype of `obj`, if it has one, otherwise the keyword
 output of `type`.
 
-[13]: fugue.janet#L146
+[13]: fugue.janet#L173
+
+## match
+
+**macro**  | [source][14]
+
+```janet
+(match x & cases)
+```
+
+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. 
+
+[14]: fugue.janet#L831
 
 ## multimethod-types-match?
 
-**function**  | [source][14]
+**function**  | [source][15]
 
 ```janet
 (multimethod-types-match? args arg-types)


@@ 398,11 414,11 @@ Check to see if the types `args` match the sequence `arg-types`,
 according to multimethod rules (ie, following prototype membership
 and using `:_` as a fallback)
 
-[14]: fugue.janet#L489
+[15]: fugue.janet#L525
 
 ## new-Root
 
-**function**  | [source][15]
+**function**  | [source][16]
 
 ```janet
 (new-Root & rest)


@@ 410,11 426,11 @@ and using `:_` as a fallback)
 
 Constructor for Root. Return a new object with Root as the prototype.
 
-[15]: eval#L-1
+[16]: eval#L-1
 
 ## prototype?
 
-**function**  | [source][16]
+**function**  | [source][17]
 
 ```janet
 (prototype? obj)


@@ 422,11 438,11 @@ Constructor for Root. Return a new object with Root as the prototype.
 
 Is `obj` the result of a `defproto ` call? 
 
-[16]: fugue.janet#L327
+[17]: fugue.janet#L354
 
 ## with-slots
 
-**macro**  | [source][17]
+**macro**  | [source][18]
 
 ```janet
 (with-slots proto obj & body)


@@ 464,11 480,11 @@ true
 @Foo{:_meta @{:object-type :instance} :name "Cosmo Kramer"}
 ```
 
-[17]: fugue.janet#L706
+[18]: fugue.janet#L742
 
 ## with-slots-as
 
-**macro**  | [source][18]
+**macro**  | [source][19]
 
 ```janet
 (with-slots-as proto obj as & body)


@@ 480,5 496,5 @@ Specifies `as` as the reference symbol for `with-slots`.
 
 See `with-slots` documentation for more details.
 
-[18]: fugue.janet#L743
+[19]: fugue.janet#L779
 

@@ 1,3 1,12 @@
+(defn- compiler-emit
+  [level msg]
+  (let [source (or (dyn :current-file) "n/a")
+        [l c] (tuple/sourcemap (dyn :macro-form ()))]
+    (eprintf "%s:%i:%i: [%s] %s" source l c level msg)))
+
+(defn- compiler-warn [msg] (compiler-emit "WARNING" msg))
+(defn- compiler-info [msg] (compiler-emit "INFO" msg))
+
 #
 # Compile-time field access
 #


@@ 56,8 65,10 @@
   (cond
     (not (symbol? obj)) (fields obj)
     (dyn obj) (fields (eval obj))
-    true (let [reg-key (string (dyn :current-file) "-" obj)]
-           (or (registry-fields reg-key) @[]))))
+    true (if-let [reg-key (string (dyn :current-file) "-" obj)
+                  listing (registry-fields reg-key)]
+           listing
+           (compiler-warn (string "no prototype definition found for " obj)))))
 
 #
 # defproto Forms


@@ 320,7 331,7 @@
   ```
   ````
   [name parent-name & fields]
-  (let [has-proto-attributes (not (zero? (mod (length fields) 2)))
+  (let [has-proto-attributes (odd? (length fields))
         fields (partition 2 fields)
         defined-fields (map (comp keyword 0) (if has-proto-attributes (array/slice fields 0 -2) fields))
         field-definitions (field-definitions name fields defined-fields)


@@ 415,13 426,14 @@
   ```
   [name proto args & body]
   (when (index-of (keyword name) (comp-aware-fields proto))
-    (printf "Warning: you are defining a method named %s on the prototype %s; there is a field of the same name on that prototype."
-            (string name)
-            (string proto)))
+    (compiler-warn
+      (string/format "you are defining a method named %s on the prototype %s; there is a field of the same name on that prototype."
+                     (string name)
+                     (string proto))))
   (upscope
     (let [current-binding (dyn name)]
       @[(unless (and current-binding (function? (current-binding :value)))
-          (print "Defining generic function for method " name "...")
+          (compiler-info (string "Defining generic function for method " name "..."))
           (defgeneric* name nil args raise-sentinel))
 
         (let [method-name (keyword name)


@@ 775,6 787,13 @@
   [proto obj as & body]
   (do-with-slots-as proto obj as body))
 
+(defn- validate-field
+  [field fields]
+  (unless fields
+    (errorf "Field validation for `%s` failed; no fields registered" (string field)))
+  (unless (index-of field fields)
+    (errorf "Field `%s` not found; got fields: %q" (string field) fields)))
+
 (defmacro @
   ```
   Compile-time Prototype field checking.


@@ 787,18 806,52 @@
   `(@ SomePrototype some-object :some-field)` - Asserts (as above) at
   compile time that `some-field` is defined on `SomePrototype`; at
   runtime, checks that `some-object` is a descendent of
-  `SomePrototype` and if so, translates to `(some-object
-  :some-field)`.
+  `SomePrototype` and if so, translates to `(some-object :some-field)`.
   ```
   [proto x &opt y]
   (let [[obj field] (if y [x y] [nil x])
         fields (fields (eval proto))]
 
-    (unless (index-of field fields)
-      (errorf "Field `%s` not found; got fields: %q" (string field) fields))
+    (validate-field field fields)
 
     (if-not obj
       field
       ~(if-not (,recursive-prototype-check ,proto ,obj)
          (errorf "Expected a %s, got: %q" ,(string proto) (,get-type-or-proto ,obj))
          ,(tuple obj field)))))
+
+(defn- validate-proto-match
+  [name attrs]
+  (let [fields (comp-aware-fields name)]
+    (loop [k :keys attrs]
+      (validate-field k fields))))
+
+(def- root-match match)
+
+(defmacro match
+  ```
+  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. 
+  ```
+  [x & cases]
+  (defn transform
+    [[pattern exp]]
+    [(match pattern
+       @[(@ '@) proto-name attrs]
+       (do
+         (validate-proto-match proto-name attrs)
+         (struct ;(kvs attrs) :_name (string proto-name)))
+
+       pattern)
+     exp])
+  
+  (let [oddlen (odd? (length cases))
+        else (if oddlen (last cases))
+        patterns (partition 2 (if oddlen (slice cases 0 -2) cases))
+        transformed (mapcat transform patterns)
+        cases (if else (array/push transformed else) transformed)]
+    (root-match x ;cases)))

@@ 382,11 382,11 @@
 
 (deftest defmethod-warning
   (def buffer @"")
-  (with-dyns [:out buffer]
+  (with-dyns [:err buffer]
     (apply fugue/defmethod '[name ToShadowField [x] "ok"]))
 
-  (is (==
-        "Warning: you are defining a method named name on the prototype ToShadowField; there is a field of the same name on that prototype.\n"
+  (is (string/has-suffix?
+        "you are defining a method named name on the prototype ToShadowField; there is a field of the same name on that prototype.\n"
         buffer)))
 
 # Define generic so we get a clean stdout


@@ 396,12 396,11 @@
   (fugue/defproto ShadowInTest nil height {})
 
   (def buffer @"")
-  (with-dyns [:out buffer]
+  (with-dyns [:err buffer]
     (apply fugue/defmethod '[height ShadowInTest [x] "ok"]))
 
-  (is (==
-        "Warning: you are defining a method named height on the prototype ShadowInTest; there is a field of the same name on that prototype.\n"
-        buffer)))
+  (is (string/has-suffix? "you are defining a method named height on the prototype ShadowInTest; there is a field of the same name on that prototype.\n"
+                          buffer)))
 
 (deftest defmulti-in-test
   (fugue/defmulti in-test-multi [:number] [n] (inc n))


@@ 462,4 461,27 @@
     (is (= "Brian May" (a-slot-haver :name)))
     (is (thrown? (fugue/@ SlotHaver not-a-member-of-queen :name)))))
 
+(fugue/defproto MyMatcher nil name {})
+
+(deftest fugue-match
+  (defn try-match [obj]
+    (fugue/match obj
+                 (@ MyMatcher {:name some-name}) (string some-name "!")
+                 {:name some-name} (string some-name ".")))
+  (is (= "Matcher!" (try-match (new-MyMatcher :name "Matcher"))))
+  (is (= "Non-Matcher." (try-match {:name "Non-Matcher"}))))
+
+(deftest fugue-match-warnings
+  (is (thrown?
+        "Field `some-other-field` not found; got fields: @[:name]"
+        (apply fugue/match '[:ok (@ MyMatcher {:some-other-field foo}) foo]))))
+
+(deftest fugue-match-else
+  (defn try-match [obj]
+    (fugue/match obj
+                 (@ MyMatcher {:name some-name}) (string some-name "!")
+                 (string obj ".")))
+  (is (= "Matcher!" (try-match (new-MyMatcher :name "Matcher"))))
+  (is (= "Non-Matcher." (try-match "Non-Matcher"))))
+
 (run-tests!)