~subsetpark/fugue

4d57639728a12d2293a34229e46fa8a0c6495fa6 — Zach Smith 5 months ago 82cfd20
Store accessor definitions in the prototype
2 files changed, 31 insertions(+), 23 deletions(-)

M fugue.janet
M test/fugue.janet
M fugue.janet => fugue.janet +28 -21
@@ 8,7 8,8 @@
  @{:_meta @{:object-type :prototype
             :fields defined-fields
             :prototype-allocations @{}
             :instance-defaults @{}}
             :instance-defaults @{}
             :accessors @{}}
    :_name name})

(def Root


@@ 45,7 46,8 @@
  (let [init-args @[]
        proto-allocated-fields @[]
        proto-allocations @{}
        instance-defaults @{}]
        instance-defaults @{}
        accessors @{}]
    (loop [[field-name attrs] :in fields
           :let [key-field (keyword field-name)]]
      # Assemble list of arguments to constructor


@@ 59,21 61,25 @@
        (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]))
        (put instance-defaults key-field (eval default-value)))
      # Assemble mapping of fields to getters (unless excluded)
      (when-let [getter-name (match attrs
                               {:getter getter} getter
                               _ field-name)]
        (put accessors field-name getter-name)))
    [init-args proto-allocated-fields proto-allocations instance-defaults accessors]))

(defn- proto-form
  "Generate the def form for a Prototype."
  [name parent fields defined-fields
   _init-args proto-allocated-fields proto-allocations instance-defaults]
   _init-args proto-allocated-fields proto-allocations instance-defaults accessors]
  ~(let [object (,bare-proto (,string ',name) ,defined-fields)]
     (,put-in object [:_meta :prototype-allocations]
        (,table/setproto
           (,table ;(,mapcat |[$0 object] ',proto-allocated-fields))
           (,get-in ',parent [:_meta :prototype-allocations])))

     (,put-in object [:_meta :instance-defaults] ',instance-defaults)
     (,put-in object [:_meta :accessors] ',accessors)
     (,merge-into object ',proto-allocations)
     (,table/setproto object ',parent)))



@@ 144,11 150,11 @@
        rec-pred-name (symbol name "*?")

        rec-pred-docstring (string/format
                             ```
                              Proto ancestor predicate: return if `obj` is a
                              descendent of %s.
                              ```
                             (string name))]
                            ```
                            Proto ancestor predicate: return if `obj` is a
                            descendent of %s.
                            ```
                            (string name))]
    ~(defn ,rec-pred-name
       ,rec-pred-docstring
       [obj]


@@ 160,8 166,12 @@
(defn- new-form
  "Generate the init form wrapper."
  [name]
  (let [init-name (symbol "new-" name)]
  (let [init-name (symbol "new-" name)
        docstring (string/format "Constructor for %s. Return a new object with %s as the prototype."
                                 (string name)
                                 (string name))]
    ~(defn ,init-name
       ,docstring
       [& rest]
       (:new ,name ;rest))))



@@ 169,19 179,16 @@


(defn- getters
  [name field-list]
  [name parent [_ _ _ _ accessors]]
  (let [forms @[]]
    (loop [[field-name attrs] :in field-list
    (loop [[field-name accessor-name] :pairs accessors
           :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)
                 qualified-name (symbol name "/" getter-name)]
                 qualified-name (symbol name "-" accessor-name)]
        (with-syms [self]
          (array/push forms ~(defn ,getter-name
          (array/push forms ~(defn ,accessor-name
                               ,docstring
                               [,self]
                               (let [current-fields (,fields ,self)]


@@ 299,7 306,7 @@
      (pred-form name)
      (pred*-form name)
      (new-form name)
      ;(getters name fields))))
      ;(getters name parent field-definitions))))

(defn prototype?
  ```

M test/fugue.janet => test/fugue.janet +3 -2
@@ 168,10 168,11 @@
(deftest getter
  (let [a-form (:new Form :unique-field :echo)
        a-dog (:new Dog)]
    (is (== @{'unique-field 'get-unique-field} (get-in Form [:_meta :accessors])))
    (is (nil? (dyn 'unique-field)))
    (is (= :echo (get-unique-field a-form)))
    (is (= :echo (Form/get-unique-field a-form)))
    (is (thrown? (Form/get-unique-field a-dog)))))
    (is (= :echo (Form-get-unique-field a-form)))
    (is (thrown? (Form-get-unique-field a-dog)))))

(fugue/defproto Form2 () second-unique-field {:getter false})