From 90ba140538b69bb7d4b396de796eb6bffda81955 Mon Sep 17 00:00:00 2001 From: Zach Smith Date: Mon, 29 Mar 2021 09:48:07 -0400 Subject: [PATCH] Replace closures with ', syntax. I don't understand how this applies to tables, but it works. --- fugue.janet | 164 +++++++++++++++++++---------------------------- test/fugue.janet | 8 +++ 2 files changed, 75 insertions(+), 97 deletions(-) diff --git a/fugue.janet b/fugue.janet index 9075f55..85aa9d1 100644 --- a/fugue.janet +++ b/fugue.janet @@ -7,8 +7,9 @@ [object-id name defined-fields] @{:_meta @{:object-type :prototype :fields defined-fields - :prototype_allocations @{} - :object-id object-id} + :prototype-allocations @{} + :object-id object-id + :instance-defaults @{}} :_name name}) (def Root @@ -19,34 +20,6 @@ (bare-proto "Prototype" []) (put :_after-init identity))) -# -# Defaults Handling -# - -(def- proto-defaults @{}) -(def- proto-allocated-values @{}) - -(defn- populate-runtime-info! - [fields parent-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 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)) - - (loop [[field-name attrs] :in fields] - # Set default value for new objects - (when-let [default-value (attrs :default)] - (set-proto-default parent-sym field-name default-value)) - # Set value to be allocated to prototype - (when-let [proto-value (attrs :allocate-value)] - (set-allocated-value parent-sym field-name proto-value)))) - # # defproto Forms # @@ -69,28 +42,25 @@ (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 [])) + [name parent parent-sym fields proto-allocated-fields proto-allocations instance-defaults] - (let [defined-fields (map |(keyword ($0 0)) fields) - docstring (proto-docstring name defined-fields)] + (let [defined-fields (map (comp keyword 0) fields)] ~(def ,name - ,docstring - (let [parent (,parent-closure) + ,(proto-docstring name defined-fields) + (let [parent ',parent object (,bare-proto ',parent-sym - (string ',name) - ,defined-fields)] + (string ',name) + ,defined-fields)] - (put-in object [:_meta :prototype_allocations] + (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))) + (put-in object [:_meta :instance-defaults] ',instance-defaults) + + (loop [[allocation-field allocation-value] :pairs ',proto-allocations] + (put object allocation-field allocation-value)) (table/setproto object parent))))) @@ -98,63 +68,64 @@ "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 - (fn ,init-name - [self ,;init-args &keys attrs] - (let [inst @{:_meta @{:object-type :instance - :object-id (,make-object-id)}}] - # Recursively lookup defaults in prototype hierarchy - (var source-of-defaults self) - (while source-of-defaults - (let [proto-id (get-in source-of-defaults [:_meta :object-id]) - defaults (,get-proto-defaults proto-id)] - (loop [[default-key default-value] :pairs defaults] - # Ensure the value inserted into a new instance is - # distinct from any previous examples. - # Theoretically we might want to directly insert - # the value, but until the usecase arises we can - # always make a copy. - (put inst default-key (,make-copy default-value)))) - # Recurse to grandparent - (set source-of-defaults (table/getproto source-of-defaults))) - - # Set positional values passed to constructor - (let [kvs (->> ,init-args - (interleave ',init-args) - (partition 2))] - (each [arg-name arg] kvs - (put inst (keyword arg-name) arg))) - - # Set additional attributes passed to constructor - (merge-into inst attrs) - - # Associate instance with Prototype - (table/setproto inst self) - - (:_after-init inst)))))) + ~(put ,name :new + (fn ,(symbol "new-from-" name) + [self ,;init-args &keys attrs] + (let [inst @{:_meta @{:object-type :instance + :object-id (keyword ',name (gensym))}}] + # Recursively lookup defaults in prototype hierarchy + (var source-of-defaults self) + (while source-of-defaults + (let [defaults (get-in source-of-defaults [:_meta :instance-defaults])] + (loop [[default-key default-value] :pairs defaults] + # Ensure the value inserted into a new instance is + # distinct from any previous examples. + # Theoretically we might want to directly insert + # the value, but until the usecase arises we can + # always make a copy. + (put inst default-key (,make-copy default-value)))) + # Recurse to grandparent + (set source-of-defaults (table/getproto source-of-defaults))) + + # Set positional values passed to constructor + (let [kvs (->> ,init-args + (interleave ',init-args) + (partition 2))] + (each [arg-name arg] kvs + (put inst (keyword arg-name) arg))) + + # Set additional attributes passed to constructor + (merge-into inst attrs) + + # Associate instance with Prototype + (table/setproto inst self) + + (:_after-init inst))))) (eval (init-form 'Root [])) (defn- field-definitions - [name fields parent-sym] + [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 (when (= (attrs :allocation) :prototype) - (put proto-allocated-fields key-field ~(symbol ,(keyword name))))) - - [init-args proto-allocated-fields])) + (put proto-allocated-fields key-field name)) + # Assemble fields to be set directly on prototype + (when-let [proto-value (attrs :allocate-value)] + (put proto-allocations key-field (eval proto-value)))) + + [init-args proto-allocated-fields proto-allocations instance-defaults])) (defn- getters [name fields] @@ -271,13 +242,12 @@ (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) + 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-closure parent-sym fields proto-allocated-fields) + (proto-form name parent parent-sym fields proto-allocated-fields proto-allocations instance-defaults) (init-form name init-args) (pred-form name parent-sym) (pred*-form name parent-sym)))) @@ -298,7 +268,7 @@ ``` [obj key value] (if-let [proto (table/getproto obj) - allocations (get-in proto [:_meta :prototype_allocations]) + allocations (get-in proto [:_meta :prototype-allocations]) allocation (allocations key) to-allocate (eval allocation)] (put to-allocate key value) diff --git a/test/fugue.janet b/test/fugue.janet index 40462ed..2ffb4dc 100644 --- a/test/fugue.janet +++ b/test/fugue.janet @@ -44,6 +44,14 @@ (is (nil? (Human :name))) (accessor-tests name [a-human Human]))) +(fugue/defproto Light () speed {:default math/inf}) + +(deftest non-idempotent-defaults + (proto-tests Light) + (let [a-light (:new Light)] + (inst-tests Light a-light) + (is (number? (a-light :speed))))) + (fugue/defproto Stack () data {:default @[]}) (deftest mutable-defaults -- 2.45.2