508d55fee21ff1dee9043130d69bcb4ea8170f14 — Zach Smith 28 days ago 66db931 master
Cleanup proto form: single pipeline with all logic in bare proto fun
3 files changed, 51 insertions(+), 42 deletions(-)

M fugue.janet
M test/fugue.janet
M test/namespaces.janet
M fugue.janet => fugue.janet +45 -40
@@ 27,21 27,21 @@
# Bootstrapping

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

(def Root
  "Root of the Fugue object hierarchy."
    (bare-proto "Prototype" [])
    (put :_init identity)))
  (base-proto "Prototype" [] @{} @{} :_init identity))

# Field Access

@@ 109,7 109,7 @@
(defn- field-definitions
  [name fields defined-fields]
  (let [field-definitions @{:init-args @[]
                            :proto-allocated-fields @[]
                            :proto-allocated-fields @{}
                            :proto-allocations @{}
                            :instance-defaults @{}
                            :getters @{}}]

@@ 124,7 124,7 @@
        (array/push (field-definitions :init-args) field-name))
      # Assemble fields that should be set directly on this prototype
      (when (= (attrs :allocation) :prototype)
        (array/push (field-definitions :proto-allocated-fields) key-field))
        (put-in field-definitions [:proto-allocated-fields key-field] true))
      # Assemble values to be set directly on prototype
      (when-let [proto-value (attrs :allocate-value)]
        (put-in field-definitions [:proto-allocations key-field] proto-value))

@@ 153,15 153,16 @@
   {:proto-allocated-fields proto-allocated-fields
    :proto-allocations to-allocate
    :instance-defaults instance-defaults}]
  ~(let [object (,bare-proto (,string ',name) ,defined-fields)
         parent (if (symbol? ',parent) ,parent ',Root)]
     (,put-in object [:_meta :prototype-allocations]
           (,table ;(,mapcat |[$0 object] ,proto-allocated-fields))
           (,get-in parent [:_meta :prototype-allocations])))
     (,put-in object [:_meta :instance-defaults] ,instance-defaults)
     (,merge-into object ,to-allocate)
     (,table/setproto object parent)))
  ~(let [parent (if (symbol? ',parent) ,parent ',Root)]
          ;(,kvs ,to-allocate))
       (,table/setproto parent))))

(defn- init-form
  "Generate the form that puts the object constructor method."

@@ 392,12 393,15 @@
  all descendents of that prototype.
  [obj key value]
  (if-let [proto (table/getproto obj)
           allocations (get-in proto [:_meta :prototype-allocations])
           allocation (allocations key)
           to-allocate allocation]
    (put to-allocate key value)
    (put obj key value)))
  (var source-of-defaults obj)
  (while source-of-defaults
    (let [prototype-allocations (get-in source-of-defaults [:_meta :prototype-allocations])]
      (if (and prototype-allocations (in prototype-allocations key)) (break))
      # Recurse to grandparent
      (set source-of-defaults (table/getproto source-of-defaults))))

  (let [dest (or source-of-defaults obj)]
    (put dest key value)))

(def- raise-sentinel (gensym))

@@ 510,27 514,27 @@
# Multimethod Closures

(def- var-cases @{})
(def- multi-cases @{})

(defn- set-multi-default
  (unless (dyn name)
    (setdyn name {:private true :value @{}})))
  (unless (in multi-cases name)
    (put multi-cases name @{})))

(defn- put-multi-case
  [sym name types fun]
  (let [multi-cases ((dyn sym) :value)]
    (put-case name types fun multi-cases)))
  [name types fun]
  (put-case name types fun multi-cases))

(defn- get-multi-cases
  [sym name]
  (let [multi-cases ((dyn sym) :value)]
    (get-cases name multi-cases)))
  (get-cases name multi-cases))

# Open Multi Closures

(def- var-cases @{})

(defn- put-var-case
  [f types fun]
  (put-case f types fun var-cases))

@@ 683,13 687,14 @@
  [name multi-types args & body]

  (let [cases-sym (symbol "_fugue-multi-cases-" name)]
    (set-multi-default cases-sym)
    (put-multi-case cases-sym name multi-types (make-case args body))
  # Nominal case handling: group declared cases by concating the
  # current file with the name of the function.
  (let [cases-key (keyword (dyn :current-file) "-" name)]
    (set-multi-default cases-key)
    (put-multi-case cases-key multi-types (make-case args body))

    (with-syms [args]
      (let [cases (get-multi-cases cases-sym name)
      (let [cases (get-multi-cases cases-key)
            cond-form (construct-cond (string name) cases args)
            docstring (make-docstring cases)]
        (emit-defn name docstring args cond-form)))))

M test/fugue.janet => test/fugue.janet +5 -2
@@ 118,12 118,14 @@

(fugue/defproto Editor () mode {:allocate-value "vi"})
(fugue/defproto Light () speed {:allocate-value math/inf})
(fugue/defproto Physics () light {:allocate-value Light})

(deftest allocate-value
  (proto-tests Editor)
  (let [an-editor (:new Editor)
        another-editor (:new Editor)
        some-light (:new Light)]
        some-light (:new Light)
        a-physics (:new Physics)]
    (inst-tests Editor an-editor)
    (fugue/allocate an-editor :mode "emacs")
    # The prototype has been allocated a value for `:mode`, which is

@@ 134,7 136,8 @@
    (is (= "emacs" (an-editor :mode)))
    (accessor-tests mode [an-editor another-editor Editor])
    (is (= :number (type (some-light :speed))))
    (is (> (some-light :speed) 0))))
    (is (> (some-light :speed) 0))
    (is (= Light (a-physics :light)))))

(fugue/defproto Dog ()
                name {:allocate-value "Fido"}

M test/namespaces.janet => test/namespaces.janet +1 -0
@@ 19,6 19,7 @@

(deftest overlapping-defmultis
  (is (= "ok!" (a/g "ok")))
  # g was defined for strings in a, but not b.
  (is (thrown? (b/g "ok")))
  (is (= 12 (b/g 10))))