~subsetpark/fugue

27f81a2530af17120b872f0472f6a9ee85b86a95 — Zach Smith 6 months ago 90ba140
Remove object-id
3 files changed, 50 insertions(+), 82 deletions(-)

M README.md
M fugue.janet
M test/fugue.janet
M README.md => README.md +16 -16
@@ 57,14 57,14 @@ be selected for any descendent prototype instances.

## fugue

[Root](#Root), [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-id](#get-type-or-proto-id), [multimethod-types-match?](#multimethod-types-match), [prototype?](#prototype)
[Root](#Root), [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), [prototype?](#prototype)

## Root

**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 @{ :prototype-allocations @{} :object-type :prototype :fields () :instance-defaults @{}} :_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#L292
[2]: fugue.janet#L257

## 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#L630
[3]: fugue.janet#L572

## 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#L326
[4]: fugue.janet#L291

## 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#L337
[5]: fugue.janet#L302

## defmulti



@@ 155,7 155,7 @@ Example usage :
> (defmulti add [:string] [s] (string s "!"))
> (def a-foo (:new Foo))
> (add a-foo)
@Foo{:value 1 :_meta @{:object-id :Foo_00001v :object-type :instance}}
@Foo{:value 1 :_meta @{:object-type :instance}}
> (add 1)
2
> (add "s")


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

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

## defproto



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

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

## 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#L643
[8]: fugue.janet#L585

## fields



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

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

## get-type-or-proto-id
## get-type-or-proto

**function**  | [source][10]

```janet
(get-type-or-proto-id obj)
(get-type-or-proto obj)
```

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

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

## 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#L483
[11]: fugue.janet#L425

## prototype?



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

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

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


M fugue.janet => fugue.janet +33 -61
@@ 4,19 4,16 @@

(defn- bare-proto
  "Basic prototype table."
  [object-id name defined-fields]
  [name defined-fields]
  @{:_meta @{:object-type :prototype
             :fields defined-fields
             :prototype-allocations @{}
             :object-id object-id
             :instance-defaults @{}}
    :_name name})

(def Root
  "Root of the Fugue object hierarchy."
  (->
    "top"
    (keyword (gensym))
    (bare-proto "Prototype" [])
    (put :_after-init identity)))



@@ 42,19 39,21 @@

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

  (let [defined-fields (map (comp keyword 0) fields)]
    ~(def ,name
       ,(proto-docstring name defined-fields)
       (let [parent ',parent
             object (,bare-proto ',parent-sym
                                   (string ',name)
                                   ,defined-fields)]
             object (,bare-proto (string ',name) ,defined-fields)
             proto-allocations @{}]

         (each field ',proto-allocated-fields
           (put proto-allocations field ',name))
         (put-in object [:_meta :prototype-allocations]
                 (table/setproto
                  ',proto-allocated-fields
                  proto-allocations
                  (get-in parent [:_meta :prototype-allocations])))

         (put-in object [:_meta :instance-defaults] ',instance-defaults)


@@ 71,8 70,7 @@
  ~(put ,name :new
        (fn ,(symbol "new-from-" name)
          [self ,;init-args &keys attrs]
          (let [inst @{:_meta @{:object-type :instance
                                  :object-id (keyword ',name (gensym))}}]
          (let [inst @{:_meta @{:object-type :instance}}]
            # Recursively lookup defaults in prototype hierarchy
            (var source-of-defaults self)
            (while source-of-defaults


@@ 107,23 105,23 @@
(defn- field-definitions
  [name fields]
  (let [init-args @[]
        proto-allocated-fields @{}
        proto-allocated-fields @[]
        proto-allocations @{}
        instance-defaults @{}]
    (loop [[field-name attrs] :in fields
           :let [key-field (keyword field-name)]]
      # Assemble mapping of fields to default values for instances
      (when-let [default-value (attrs :default)]
        (put instance-defaults key-field (eval default-value)))
      # Assemble list of arguments to constructor
      (when (attrs :init?)
        (array/push init-args field-name))
      # Assemble mapping of proto-only variables to their prototypes
      # Assemble fields that should be set directly on this prototype
      (when (= (attrs :allocation) :prototype)
        (put proto-allocated-fields key-field name))
      # Assemble fields to be set directly on prototype
        (array/push proto-allocated-fields key-field))
      # Assemble values to be set directly on prototype
      (when-let [proto-value (attrs :allocate-value)]
        (put proto-allocations key-field (eval proto-value))))
        (put proto-allocations key-field (eval proto-value)))
      # Assemble mapping of fields to default values for instances
      (when-let [default-value (attrs :default)]
        (put instance-defaults key-field (eval default-value))))
    
    [init-args proto-allocated-fields proto-allocations instance-defaults]))



@@ 145,7 143,7 @@

(defn- pred-form
  "Generate the defn form for the Prototype predicate."
  [name parent-sym]
  [name parent]
  (let [pred-name (pred-name name)
        pred-docstring (string/format
                         ```


@@ 154,13 152,11 @@
                          ```
                         (string name))]
    ~(defn ,pred-name ,pred-docstring [obj]
       (and (table? obj)
            (= ',parent-sym
               (get-in (table/getproto obj) [:_meta :object-id]))))))
       (and (table? obj) (= ',parent (table/getproto obj))))))

(defn- pred*-form
  "Generate the defn form for the recursive Prototype predicate."
  [name parent-sym]
  [name]
  (let [pred-name (pred-name name)
        rec-pred-name (symbol name "*?")



@@ 243,14 239,13 @@

  (let [fields (partition 2 fields)
        parent (if (symbol? parent-name) (eval parent-name) Root)
        parent-sym (keyword (in parent :_name) (gensym))
        [init-args proto-allocated-fields proto-allocations instance-defaults] (field-definitions name fields)]
    (array/push
      (getters name fields)
      (proto-form name parent parent-sym fields proto-allocated-fields proto-allocations instance-defaults)
      (proto-form name parent fields proto-allocated-fields proto-allocations instance-defaults)
      (init-form name init-args)
      (pred-form name parent-sym)
      (pred*-form name parent-sym))))
      (pred-form name parent)
      (pred*-form name))))

(defn prototype?
  ```


@@ 343,22 338,13 @@
        obj-fields (or (get-in obj [:_meta :fields]) @[])]
    (array ;proto-fields ;obj-fields)))

(defn- get-object-id-or-object
  [obj]
  (match obj
    @{:_meta @{:object-id id}} id
    _ obj))

(defn get-type-or-proto-id
(defn get-type-or-proto
  ```
  Return the prototype of `obj`, if it has one, otherwise the keyword
  output of `type`.
  ```
  [obj]
  (if (table? obj)
    (let [proto (table/getproto obj)]
      (get-object-id-or-object proto))
    (type obj)))
  (if (table? obj) (table/getproto obj) (type obj)))

#
# Multimethod Helpers


@@ 369,7 355,7 @@
  (let [f |(case $
             '_ nil
             :_ nil
             $)]
             (eval $))]
    (tuple/slice (map f types))))

(defn- get-cases


@@ 389,8 375,8 @@

(defn- put-case
  [name types fun store]
  (let [replaced (replace-placeholder-symbols types)]
    (put-in store [name replaced] fun)))
  (let [types (replace-placeholder-symbols types)]
    (put-in store [name types] fun)))

#
# Private Multimethod State


@@ 399,18 385,6 @@
(def- multi-cases @{})
(def- var-cases @{})

(defn- evaluate-for-object-id
  ```
  Given some symbol, try to evaluate it and get the resulting
  object-id. If there is none, just return the symbol.
  ```
  [sym]
  (if (= '_ sym) sym
    (let [evaled (eval sym)]
      (if (table? evaled)
        (get-object-id-or-object evaled)
        sym))))

#
# Multimethod Closures
#


@@ 422,9 396,8 @@

(defn- put-multi-case
  [sym name types fun]
  (let [multi-cases ((dyn sym) :value)
        types-or-ids (map evaluate-for-object-id types)]
    (put-case name types-or-ids fun multi-cases)))
  (let [multi-cases ((dyn sym) :value)]
    (put-case name types fun multi-cases)))

(defn- get-multi-cases
  [sym name]


@@ 439,8 412,7 @@

(defn- put-var-case
  [f types fun]
  (let [types-or-ids (map evaluate-for-object-id types)]
    (put-case f types-or-ids fun var-cases)))
  (put-case f types fun var-cases))

(defn- get-var-cases
  [name]


@@ 469,7 441,7 @@
        (set vk (next arg-types vk))
        (if (= nil vk) (break))
        (unless (or (= (arg-types vk) nil)
                    (= (get-type-or-proto-id (args kk)) (arg-types vk)))
                    (= (get-type-or-proto (args kk)) (arg-types vk)))
          (set res false)
          (break)))
      res)))


@@ 535,7 507,7 @@
  > (defmulti add [:string] [s] (string s "!"))
  > (def a-foo (:new Foo))
  > (add a-foo)
  @Foo{:value 1 :_meta @{:object-id :Foo_00001v :object-type :instance}}
  @Foo{:value 1 :_meta @{:object-type :instance}}
  > (add 1)
  2
  > (add "s")

M test/fugue.janet => test/fugue.janet +1 -5
@@ 8,8 8,7 @@

(defn- proto-tests [proto]
  (is (fugue/prototype? proto))
  (is (= fugue/Root (table/getproto proto)))
  (is (string/has-prefix? "Prototype" (get-in proto [:_meta :object-id]))))
  (is (= fugue/Root (table/getproto proto))))

(defmacro- inst-tests [proto inst]
  (upscope


@@ 117,7 116,6 @@

(deftest inheritance
  (is (= Dog (table/getproto Pekingese)))
  (is (string/has-prefix? "Dog" (get-in Pekingese [:_meta :object-id])))

  (let [a-pekingese (:new Pekingese)]



@@ 125,8 123,6 @@
    (accessor-tests name [a-pekingese Dog Pekingese])
    (accessor-tests size [a-pekingese Pekingese])

    (is (string/has-prefix? "Pekingese" (get-in a-pekingese [:_meta :object-id])))

    (is (nil? (size Dog)))
    (is (= "Fido" (name a-pekingese)))
    (is (= "Extremely Small" (size a-pekingese)))