~subsetpark/fugue

64a9e7a02160a8043f46c494a693a932a0a244de — Zach Smith 6 months ago 4998bb5
Encapsulate default handlers
2 files changed, 61 insertions(+), 58 deletions(-)

M README.md
M fugue.janet
M README.md => README.md +12 -12
@@ 64,7 64,7 @@ be selected for any descendent prototype instances.
**table**  | [source][1]

```janet
@{:new <function new-from-root> :_meta @{ :object-type :prototype :fields () :prototype_allocations @{} :object-id :top_000000} :_name "Prototype" :_after-init <function identity>}
@{:new <function new-from-Root> :_meta @{ :object-type :prototype :fields () :prototype_allocations @{} :object-id :top_000000} :_name "Prototype" :_after-init <function identity>}
```

Root of the Fugue object hierarchy.


@@ 84,7 84,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.

[2]: fugue.janet#L294
[2]: fugue.janet#L292

## declare-open-multi



@@ 100,7 100,7 @@ Extending an open multimethod (see `extend-multi`) from any other
environment makes the case extension available wherever the
multimethod has been imported.

[3]: fugue.janet#L632
[3]: fugue.janet#L630

## defgeneric



@@ 115,7 115,7 @@ first argument has a method corresponding to the name of the
function, call that object 's method with the arguments. Otherwise,
evaluate `body`.

[4]: fugue.janet#L328
[4]: fugue.janet#L326

## defmethod



@@ 133,7 133,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`.

[5]: fugue.janet#L339
[5]: fugue.janet#L337

## defmulti



@@ 205,7 205,7 @@ repl:12:> (cat "hello" 100)
"hello #100"
```

[6]: fugue.janet#L556
[6]: fugue.janet#L554

## defproto



@@ 275,7 275,7 @@ repl:47:> (speak (:new Pekingese))
"My name is Fido and I am Extremely Small"
```

[7]: fugue.janet#L208
[7]: fugue.janet#L206

## extend-multi



@@ 293,7 293,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.

[8]: fugue.janet#L645
[8]: fugue.janet#L643

## fields



@@ 306,7 306,7 @@ wherever the multimethod is imported.
Return all the defined fields for `obj` and its prototype
hierarchy.

[9]: fugue.janet#L366
[9]: fugue.janet#L364

## get-type-or-proto-id



@@ 319,7 319,7 @@ hierarchy.
Return the prototype of `obj`, if it has one, otherwise the keyword
output of `type`.

[10]: fugue.janet#L384
[10]: fugue.janet#L382

## multimethod-types-match?



@@ 333,7 333,7 @@ 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)

[11]: fugue.janet#L485
[11]: fugue.janet#L483

## prototype?



@@ 345,5 345,5 @@ and using `:_` as a fallback)

Is `obj` the result of a `defproto ` call? 

[12]: fugue.janet#L287
[12]: fugue.janet#L285


M fugue.janet => fugue.janet +49 -46
@@ 14,10 14,10 @@
(def Root
  "Root of the Fugue object hierarchy."
  (->
   "top"
   (keyword (gensym))
   (bare-proto "Prototype" [])
   (put :_after-init identity)))
    "top"
    (keyword (gensym))
    (bare-proto "Prototype" [])
    (put :_after-init identity)))

#
# Defaults Handling


@@ 26,26 26,19 @@
(def- proto-defaults @{})
(def- proto-allocated-values @{})

(defn- set-proto-default
  [sym name value]
  (unless (in proto-defaults sym) (put proto-defaults sym @{}))
  (put-in proto-defaults [sym (keyword name)] value))

(defn- set-allocated-value
  [sym name value]
  (unless (in proto-allocated-values sym) (put proto-allocated-values sym @{}))
  (put-in proto-allocated-values [sym (keyword name)] value))
(defn- populate-runtime-info!
  [fields parent-sym]

(defn- get-proto-defaults
  [sym]
  (in proto-defaults sym []))
  (defn set-proto-default
    [sym name value]
    (unless (in proto-defaults sym) (put proto-defaults sym @{}))
    (put-in proto-defaults [sym (keyword name)] value))

(defn- get-allocated-values
  [sym]
  (in proto-allocated-values sym []))
  (defn set-allocated-value
    [sym name value]
    (unless (in proto-allocated-values sym) (put proto-allocated-values sym @{}))
    (put-in proto-allocated-values [sym (keyword name)] value))

(defn- populate-runtime-info!
  [fields parent-sym]
  (loop [[field-name attrs] :in fields]
    # Set default value for new objects
    (when-let [default-value (attrs :default)]


@@ 70,26 63,31 @@
(defn- proto-docstring
  [name defined-fields]
  (string/format
   "%s Prototype.\nFields: %q"
   (string name)
   ((comp freeze (partial map symbol)) defined-fields)))
    "%s Prototype.\nFields: %q"
    (string name)
    ((comp freeze (partial map symbol)) defined-fields)))

(defn- proto-form
  "Generate the def form for a Prototype."
  [name parent-closure parent-sym fields proto-allocated-fields]

  (defn get-allocated-values
    [sym]
    (in proto-allocated-values sym []))

  (let [defined-fields (map |(keyword ($0 0)) fields)
        docstring (proto-docstring name defined-fields)]
    ~(def ,name
       ,docstring
       (let [parent (,parent-closure)
             object (,bare-proto ',parent-sym
                                   (string ',name)
                                   ,defined-fields)]
                       (string ',name)
                       ,defined-fields)]

         (put-in object [:_meta :prototype_allocations]
                 (table/setproto
                  ,proto-allocated-fields
                  (get-in parent [:_meta :prototype_allocations])))
                   ,proto-allocated-fields
                   (get-in parent [:_meta :prototype_allocations])))

         (loop [[field value] :pairs (,get-allocated-values ',parent-sym)]
           (put object field (eval value)))


@@ 99,6 97,11 @@
(defn- init-form
  "Generate the form that puts the object constructor method."
  [name init-args]

  (defn get-proto-defaults
    [sym]
    (in proto-defaults sym []))

  (let [init-name (symbol "new-from-" name)
        make-object-id |(keyword name (gensym))]
    ~(put ,name :new


@@ 123,8 126,8 @@

              # Set positional values passed to constructor
              (let [kvs (->> ,init-args
                              (interleave ',init-args)
                              (partition 2))]
                             (interleave ',init-args)
                             (partition 2))]
                (each [arg-name arg] kvs
                  (put inst (keyword arg-name) arg)))



@@ 157,15 160,15 @@
  [name fields]
  (seq [[field-name attrs] :in fields
        :let [key-field (keyword field-name)]]
       # Allow specifying another getter name or `false`
       # for no getter
       (when-let [docstring (string "Get " field-name " from a " name)
                  getter-name (match attrs
                                {:getter getter} getter
                                _ field-name)]
         (with-syms [self]
           ~(defn ,getter-name ,docstring [,self]
              (in ,self ,key-field))))))
    # Allow specifying another getter name or `false`
    # for no getter
    (when-let [docstring (string "Get " field-name " from a " name)
               getter-name (match attrs
                             {:getter getter} getter
                             _ field-name)]
      (with-syms [self]
        ~(defn ,getter-name ,docstring [,self]
           (in ,self ,key-field))))))

(defn- pred-name [name] (symbol name "?"))



@@ 263,21 266,21 @@
  ```
  ````
  [name parent-name & fields]
  

  (unless (zero? (mod (length fields) 2))
    (error "defproto received odd number of fields"))
  

  (let [fields (partition 2 fields)
        parent-closure |(if (symbol? parent-name) (eval parent-name) Root)
        parent-sym (keyword (in (parent-closure) :_name) (gensym))
        [init-args proto-allocated-fields] (field-definitions name fields parent-sym)]
    (populate-runtime-info! fields parent-sym)
    (array/push
     (getters name fields)
     (proto-form name parent-closure parent-sym fields proto-allocated-fields)
     (init-form name init-args)
     (pred-form name parent-sym)
     (pred*-form name parent-sym))))
      (getters name fields)
      (proto-form name parent-closure parent-sym fields proto-allocated-fields)
      (init-form name init-args)
      (pred-form name parent-sym)
      (pred*-form name parent-sym))))

(defn prototype?
  ```