~subsetpark/fugue

ec9de0f48659aec3efb3eb16a89bc92e0918b389 — Zach Smith 5 months ago 2f39092
Broken test: cannot eval for parent
2 files changed, 69 insertions(+), 23 deletions(-)

M fugue.janet
M test/fugue.janet
M fugue.janet => fugue.janet +35 -18
@@ 30,6 30,18 @@
        obj-fields (or (get-in obj [:_meta :fields]) @[])]
    (array ;proto-fields ;obj-fields)))

(def- proto-field-registry
  "Keep compile-time track of field definitions"
  @{})

(defn- comp-aware-fields
  "Fields checks, even when the proto is not available yet"
  [obj]
  (cond
    (not (symbol? obj)) (fields obj)
    (dyn obj) (fields (eval obj))
    true (let [reg-key (string (dyn :current-file) "-" obj)]
           (or (get-in proto-field-registry [reg-key :fields]) @[]))))
#
# defproto Forms
#


@@ 43,36 55,39 @@

(defn- field-definitions
  [name fields]
  (let [init-args @[]
        proto-allocated-fields @[]
        proto-allocations @{}
        instance-defaults @{}
        getters @{}]
  (let [field-definitions @{:init-args @[]
                            :proto-allocated-fields @[]
                            :proto-allocations @{}
                            :instance-defaults @{}
                            :getters @{}}]
    (put field-definitions :fields (map (comp keyword 0) fields))

    (loop [[field-name attrs] :in fields
           :let [key-field (keyword field-name)]]
      # Assemble list of arguments to constructor
      (when (attrs :init?)
        (array/push init-args field-name))
        (array/push (field-definitions :init-args) field-name))
      # Assemble fields that should be set directly on this prototype
      (when (= (attrs :allocation) :prototype)
        (array/push proto-allocated-fields key-field))
        (array/push (field-definitions :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-in field-definitions [: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)))
        (put-in field-definitions [: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 getters field-name getter-name)))
    [init-args proto-allocated-fields proto-allocations instance-defaults getters]))
        (put-in field-definitions [:getters field-name] getter-name)))
    (put proto-field-registry (string (dyn :current-file) "-" name) field-definitions)
    field-definitions))

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


@@ 186,7 201,7 @@
(eval (new-form 'Root))

(defn- getters
  [name parent [_ _ _ _ getter-list]]
  [name parent {:getters getter-list}]
  (seq [[field-name getter-name] :pairs getter-list
        :let [key-field (keyword field-name)
              docstring (string "Get " field-name " from a " name)]]


@@ 271,15 286,13 @@
  ```
  ````
  [name parent-name & fields]

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

  (let [fields (partition 2 fields)
        parent (if (symbol? parent-name) (eval parent-name) Root)
        defined-fields (map (comp keyword 0) fields)
        field-definitions (field-definitions name fields)
        [init-args] field-definitions]
        field-definitions (field-definitions name fields)]
    (array
      ~(def ,name
         ,(proto-docstring name defined-fields)


@@ 288,8 301,8 @@
                        parent
                        fields
                        defined-fields
                        ;field-definitions)
           (,put :new ,(init-form name init-args))))
                        field-definitions)
           (,put :new ,(init-form name (field-definitions :init-args)))))
      (pred-form name)
      (pred*-form name)
      (new-form name)


@@ 361,6 374,10 @@
  - `__super` - Bound to the method at `name` within `__parent`.
  ```
  [name proto args & body]
  (when (index-of (keyword name) (comp-aware-fields proto))
    (printf "Warning: you are defining a method named %s on the prototype %s; there is a field of the same name on that prototype."
            (string name)
            (string proto)))
  (upscope
    (let [current-binding (dyn name)]
      @[(unless (and current-binding (function? (current-binding :value)))

M test/fugue.janet => test/fugue.janet +34 -5
@@ 323,16 323,45 @@
  (let [a-in-test (:new InTest)]
    (inst-tests InTest a-in-test)))

(deftest defproto-child-in-test
  (fugue/defproto InTestParent nil)
  (fugue/defproto InTestChild InTestParent))

(deftest defgeneric-in-test
  (fugue/defgeneric in-test [x] (string x " ok"))
  (is (= "a ok" (in-test "a"))))

(deftest defmethod-in-test
  (fugue/defproto HasMethod ())
  (fugue/defproto HasMethod () name {})
  (fugue/defmethod in-test HasMethod [m] (m :name))
  (let [a-has-method (:new HasMethod :name "dobby")]
    (is (= "dobby" (in-test a-has-method)))))

(fugue/defproto ToShadowField nil name {})

(deftest defmethod-warning
  (def buffer @"")
  (with-dyns [:out buffer]
    (apply fugue/defmethod '[name ToShadowField [x] "ok"]))

  (is (==
        "Warning: you are defining a method named name on the prototype ToShadowField; there is a field of the same name on that prototype.\n"
        buffer)))

# Define generic so we get a clean stdout
(fugue/defgeneric height [x] :ok)

(deftest defmethod-warning-in-test
  (fugue/defproto ShadowInTest nil height {})

  (def buffer @"")
  (with-dyns [:out buffer]
    (apply fugue/defmethod '[height ShadowInTest [x] "ok"]))

  (is (==
        "Warning: you are defining a method named height on the prototype ShadowInTest; there is a field of the same name on that prototype.\n"
        buffer)))

(deftest defmulti-in-test
  (fugue/defmulti in-test-multi [:number] [n] (inc n))
  (is (= 2 (in-test-multi 1))))


@@ 362,10 391,10 @@
(deftest slots-as-test
  (let [a-slot-haver (:new SlotHaver)]
    (def res (fugue/with-slots-as SlotHaver a-slot-haver s
                               (set (s name) "will shortz")
                               (is (= "will shortz" (s name)))
                               (is (= "will shortz" (s :name)))
                               (is (= "will shortz" (name s)))))
                                  (set (s name) "will shortz")
                                  (is (= "will shortz" (s name)))
                                  (is (= "will shortz" (s :name)))
                                  (is (= "will shortz" (name s)))))
    (is (= res a-slot-haver))
    (is (= "will shortz" (a-slot-haver :name)))))