2 files changed, 156 insertions(+), 107 deletions(-)

M fugue.janet
M test/fugue.janet

@@ 200,7 200,9 @@
   output of `type`.
   ```
   [obj]
-  (if (table? obj) (table/getproto obj) (type obj)))
+  (if (table? obj)
+    (or (table/getproto obj) (type obj))
+    (type obj)))
 
 (defn- pred-name [name] (symbol name "?"))
 


@@ 286,60 288,59 @@
 
   ## Usage
 
-  `name` should be any symbol. The resulting prototype will be
-  named after it.
+  `name` should be any symbol. The resulting prototype will be named after it.
 
-  `parent-name` is required; it can be an existing prototype, *or*
-  some null-ish value. If null-ish (`nil` or `()` should make the most
-  sense...) the parent of the prototype will be set to `fugue/Root`.
+  `parent-name` is required; it can be an existing prototype, *or* some
+  null-ish value. If null-ish (`nil` or `()` should make the most sense...) the
+  parent of the prototype will be set to `fugue/Root`.
 
   `fields` should be 0 or more pairs of the following format:
 
   `<field-name> <field-attributes>`
 
   Where `field-name` is a field to define on the prototype and
-  `field-attributes` is a struct describing the field. The following
-  field attributes are currently recognized:
+  `field-attributes` is a struct describing the field. The following field
+  attributes are currently recognized:
+
+  - `:default`: provide a default value for all new instances of this prototype
+
+  - `:init?`: if truthy, then this field will be a required parameter to the
+  prototype's constructor
 
-  - `:default`: provide a default value for all new instances of this
-  prototype
-  - `:init?`: if truthy, then this field will be a required parameter
-  to the prototype 's constructor
   - `:allocation`: if `:prototype`, then `fugue/allocate` will always act on
   the prototype when putting this field.
+
   - `:allocate-value`: this field will have this attribute set at the
-  prototype, so that any children without their own values will
-  inherit it.
-  - `:getter`: specify a name for the defined function to access this
-  field (by default, has the same name as the field). Specify `false`
-  to prevent a getter from being defined.
-
-  `defproto` will define a getter function for each of the defined
-  fields, unless `:getter` is false.
-
-  `defproto` will also create a `:new` method in the created
-  prototype. This will take as positional arguments all of the fields
-  specified as `init?`, and then accept in `&keys` format any other
-  attributes to set on this object.
-
-  The special method `:_init` will be called as the last step in the
-  `:new` constructor. It can be defined for a prototype (see
-  `defmethod`) to take a new instance and to make any arbitrary
-  mutations on the instance or prototype as part of object
-  instantiation. By default it simply returns the instance.
-
-  The value provided to a field's `:default` entry will be inserted
-  directly to the instance. Thus, mutable/referenced terms like tables
-  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>`.
+  prototype, so that any children without their own values will inherit it.
+
+  - `:getter`: specify a name for the defined function to access this field (by
+  default, has the same name as the field). Specify `false` to prevent a getter
+  from being defined.
+
+  `defproto` will define a getter function for each of the defined fields,
+  unless `:getter` is false.
+
+  `defproto` will also create a `:new` method in the created prototype. This
+  will take as positional arguments all of the fields specified as `init?`, and
+  then accept in `&keys` format any other attributes to set on this object.
+
+  The special method `:_init` will be called as the last step in the `:new`
+  constructor. It can be defined for a prototype (see `defmethod`) to take a
+  new instance and to make any arbitrary mutations on the instance or prototype
+  as part of object instantiation. By default it simply returns the instance.
+
+  The value provided to a field's `:default` entry will be inserted directly to
+  the instance. Thus, mutable/referenced terms like tables 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>`.
 
   ---
 


@@ 377,7 378,7 @@
 
 (defn prototype?
   ```
-  Is `obj` the result of a `defproto ` call? 
+  Is `obj` the result of a `defproto ` call?
   ```
   [obj]
   (and (Root*? obj)


@@ 385,10 386,10 @@
 
 (defn allocate
   ```
-  Allocation-aware put. If `obj` has inherited an allocation to a
-  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.
+  Allocation-aware put. If `obj` has inherited an allocation to a 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.
   ```
   [obj key value]
   (var source-of-defaults obj)


@@ 425,10 426,9 @@
 
 (defmacro defgeneric
   ```
-  Define a generic function. When this function is called, if the
-  first argument has a method corresponding to the name of the
-  function, call that object 's method with the arguments. Otherwise,
-  evaluate `body`.
+  Define a generic function. When this function is called, if the first
+  argument has a method corresponding to the name of the function, call that
+  object 's method with the arguments. Otherwise, evaluate `body`.
   ```
   [name & rest]
   (let [[docstring args body] (if (string? (first rest))


@@ 451,8 451,8 @@
 
 (defmacro defmethod
   ```
-  Simple single-dispatch method definition. Roughly equivalent to
-  `put` ing a function directly into a prototype.
+  Simple single-dispatch method definition. Roughly equivalent to `put` ing a
+  function directly into a prototype.
 
   Defines a few symbols for reference in the body of the method.
 


@@ 497,10 497,10 @@
   (defn f [sym]
     (cond
       (or (= '_ sym) (= :_ sym)) nil
-      (or (tuple? sym) (struct? sym)) (compile-matcher sym)
+      (not (or (symbol? sym) (keyword? sym))) (compile-matcher sym)
       (let [evaled (eval sym)]
         (if (not (or (table? evaled) (keyword? evaled)))
-          (errorf `Multimethod type error. Expected keyword or prototype, got:
+          (errorf `Multimethod type error. Expected keyword, prototype, or match specification; got:
                    %q of type %q`
                   sym
                   (type sym))


@@ 562,6 562,7 @@
       (var kk nil)
       (var vk nil)
       (var res true)
+
       (while true
         (set kk (next args kk))
         (if (= nil kk) (break))


@@ 569,22 570,26 @@
         (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)))
+        (let [arg (args kk)
+              arg-type (arg-types vk)]
+          (unless (or (nil? arg-type)
+                      (and (function? arg-type) (arg-type arg))
+                      (= (get-type-or-proto arg) arg-type))
+            (set res false)
+            (break))))
 
       res)))
 
 (defn- make-case
   [multi-types args body]
   (let [destructurable @[]]
-    (each [type arg] (map tuple multi-types args)
+    (each [type-spec arg] (map tuple multi-types args)
       (cond
-        (struct? type) (array/concat destructurable @[type arg])
-        (tuple? type) (array/concat destructurable @[(first type) arg])))
+        (or (keyword? type-spec) (symbol? type-spec)) :ok
+        (tuple? type-spec) (array/concat destructurable
+                                         @[(first type-spec) arg])
+        (array/concat destructurable @[type-spec arg])))
+
     (eval ~(fn multimethod-case
              ,args
              (let ,destructurable


@@ 624,8 629,7 @@
 
 (defmacro defmulti
   ````
-  Define a multimethod based on all the arguments passed to the
-  function.
+  Define a multimethod based on all the arguments passed to the function.
 
   Example usage :
 


@@ 643,17 647,36 @@
   "s!"
   ```
 
-  `defmulti` takes a sequence of type-or-prototypes, and builds a
-  function which will check its arguments against those types (as well
-  as all other ones specified in other `defmulti` calls to the same
-  function name), and execute the function body for the matching type
-  signature.
+  `defmulti` takes a sequence of *multimethod specifications*, and builds a
+  function which will check its arguments against those types (as well as all
+  other ones specified in other `defmulti` calls to the same function name),
+  and execute the function body for the matching type signature.
+
+  A multimethod specification can be any of the following data types:
+
+  - a **keyword** representing the name of a simple or abstract type; for
+  instance, `:number` or `:string`. This will match against values of this
+  type.
+
+  - A **symbol** referring to an existing table. This will match against tables
+  which have this table as a prototype.
 
-  In addition to type names or prototypes, you can use the symbol `_`
-  or keyword `:_` as a wildcard that means "match any type". For
-  instance,
+  - The **fallback symbols** `:_` and `_`. These will match against anything.
 
-  ``` 
+  - A **match specification**, ie, a pattern understood by the `match` macro,
+  as long as it isn't one of the above values. This will match against any
+  value that would be matched in an execution of `match`. This includes tuples
+  with arbitrary predicates.
+
+  Multimethod specs match in order of *most specific* to *least specific*; that
+  is:
+
+  1. Match specifications
+  2. Prototypes
+  3. Simple types
+  4. Fallback
+
+  ```
   repl:2:> (defmulti cat [:string :_] [s1 s2] (string s1 s2))
   repl:3:> (cat "hello " "world!")
   "hello world!"


@@ 665,19 688,18 @@
   in _thunk [repl] (tailcall) on line 5, column 1
   ```
 
-  Defining a multimethod with the signature `[:string :_]` will match
-  on any two arguments if the first one is a string.
+  Defining a multimethod with the signature `[:string :_]` will match on any
+  two arguments if the first one is a string.
 
-  A multimethod without wilcards will be preferred to one with one in
-  the same position. For instance, if we define an additional
-  multimethod:
+  A multimethod without wilcards will be preferred to one with one in the same
+  position. For instance, if we define an additional multimethod:
 
   ```
   repl:8:> (defmulti cat [:string :number] [s n] (string s " #" n))
   ```
 
-  Then that more specific method will be preferred and the wildcard
-  will be a fallback if the specific one doesn't match:
+  Then that more specific method will be preferred and the wildcard will be a
+  fallback if the specific one doesn't match:
 
   ```
   repl:10:> (cat "hello " @"world")


@@ 737,8 759,8 @@
 
   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.
+  Whenever a case is added to `multi`, that case is available wherever the
+  multimethod is imported.
   ```
   [multi multi-types args & body]
   (let [ref (and (dyn multi) (in (dyn multi) :ref))]


@@ 786,16 808,15 @@
 
   Introduces two useful forms for referring to `obj`.
 
-  It introduces a *reference symbol* - `@` by default
-  (see `with-slots-as `to specify the symbol).
+  It introduces a *reference symbol* - `@` by default (see `with-slots-as `to
+  specify the symbol).
 
   The pattern `(@ <field name>)`, where `<field name>` is a symbol, is
-  transformed into `(obj (keyword <field name>))`, if and only if
-  `<field name>` is defined for `proto`, so that `(@ name)` or its
-  setter form `(set (@ name) foo)` do the right thing.
+  transformed into `(obj (keyword <field name>))`, if and only if `<field
+  name>` is defined for `proto`, so that `(@ name)` or its setter form `(set (@
+  name) foo)` do the right thing.
 
-  The reference symbol by itself is introduces as a reference to
-  `obj`.
+  The reference symbol by itself is introduces as a reference to `obj`.
 
   Returns `obj`.
 


@@ 837,10 858,10 @@
   `(@ SomePrototype :some-field)` - Translates into `:some-field`, if
   `some-field` is defined on `SomePrototype`.
 
-  `(@ 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 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)`.
   ```
   [proto x &opt y]
   (let [[obj field] (if y [x y] [nil x])


@@ 858,10 879,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. 
+  - `(@ <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

@@ 254,6 254,15 @@
 (fugue/defmulti cat [_ :number] [m n] (+ m n))
 (fugue/defmulti cat [_ _] [x y] (string/format "Falling back to %q<>%q" x y))
 
+(fugue/defproto CalculatorCell nil special-value {:init? true})
+
+(fugue/defmulti cat
+                [:table :number] [t n]
+                (string (t :generic-value) "+" n))
+(fugue/defmulti cat
+                [CalculatorCell :number] [c n]
+                (string (c :special-value) "+" n))
+
 (deftest multi-specialization
   # [:string :string] matches [:string :_]
   (is (= "hello world" (cat "hello " @"world")))


@@ 263,7 272,10 @@
   # [:number :number] matches [:_ :number]}
   (is (= 9 (cat 4 5)))
   # [:_ :_] will never match before a more specific typing
-  (is (= "Falling back to @\"x\"<>@\"y\"" (cat @"x" @"y"))))
+  (is (= "Falling back to @\"x\"<>@\"y\"" (cat @"x" @"y")))
+  # prototypes are more specific than types
+  (is (= "2+2" (cat (:new CalculatorCell 2) 2)))
+  (is (= "2+2" (cat @{:generic-value 2} 2))))
 
 (fugue/defmulti cat2 [_ :number] [n m] (+ n m))
 (fugue/defmulti cat2 [:string _] [s s2] (string s "+" s2))


@@ 418,6 430,10 @@
   (fugue/extend-multi open-in-test [:number] [n] (inc n))
   (is (= 2 (open-in-test 1))))
 
+(comment(deftest defmulti-with-proto-in-test
+  (fugue/defproto InTestForMulti nil name {})
+  (fugue/defmulti in-test-multi [InTestForMulti] [it] (it :name))))
+
 (fugue/declare-open-multi open-headless)
 
 (deftest open-defaults


@@ 500,16 516,29 @@
   (is (= "Non-Matcher." (try-match "Non-Matcher"))))
 
 (deftest matching-multis
-  (fugue/defmulti with-matching 
-                  [{:magic-key z}] [x] 
+  (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] 
+  (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}))))
 
+(deftest matching-and-destructuring-multis
+  (fugue/defmulti with-bind-matching
+                  [{:magic-key z}] [x]
+                  (inc z))
+
+  (fugue/declare-open-multi open-with-bind-matching)
+  (fugue/extend-multi open-with-bind-matching
+                      [{:magicer-key z}] [x]
+                      (inc z))
+
+  (is (= 1 (with-bind-matching {:magic-key 0})))
+  (is (= 1 (open-with-bind-matching {:magicer-key 0}))))
+
 (run-tests!)