~subsetpark/fugue

46f6be47e149c6b5053f71ab8bcf088b5259d3a2 — Zach Smith 5 months ago 4d57639
Generate qualified accessors for inherited fields
3 files changed, 35 insertions(+), 25 deletions(-)

M fugue.janet
M test/fugue.janet
M test/namespaces.janet
M fugue.janet => fugue.janet +26 -19
@@ 130,12 130,11 @@
  "Generate the defn form for the Prototype predicate."
  [name]
  (let [pred-name (pred-name name)
        pred-docstring (string/format
                         ```
                          Proto instance predicate: return if `obj` is an
                          instance (that is, a direct child) of %s.
                          ```
                         (string name))]
        pred-docstring (string/format ```
                                      Proto instance predicate: return if `obj` is an
                                      instance (that is, a direct child) of %s.
                                      ```
                                      (string name))]
    ~(defn ,pred-name
       ,pred-docstring
       [obj]


@@ 149,12 148,11 @@
  (let [pred-name (pred-name name)
        rec-pred-name (symbol name "*?")

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


@@ 177,15 175,24 @@

(eval (new-form 'Root))

(defn- all-accessors
  "Recurse upwards to generate qualified forms for inherited accessors"
  [proto acc]
  (match proto
    {:_meta {:accessors accessors}} (all-accessors
                                      (table/getproto proto)
                                      (merge acc accessors))
    nil acc))

(defn- getters
  [name parent [_ _ _ _ accessors]]
  (let [forms @[]]
    (loop [[field-name accessor-name] :pairs accessors
  (let [forms @[]
        all-accessors (all-accessors parent accessors)]
    (loop [[field-name accessor-name] :pairs all-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)
                 # Generate qualified (prefixed with Proto name)
                 # accessor as well as unqualified
                 qualified-name (symbol name "-" accessor-name)]
        (with-syms [self]
          (array/push forms ~(defn ,accessor-name


@@ 194,9 201,9 @@
                               (let [current-fields (,fields ,self)]
                                 (unless (,index-of ,key-field current-fields)
                                   (,errorf "type error: expected proto with field %q, got %s with fields: %q"
                                            ,key-field
                                            (in ,self :_name)
                                            current-fields)))
                                      ,key-field
                                      (in ,self :_name)
                                      current-fields)))
                               (,in ,self ,key-field)))
          (array/push forms ~(defn ,qualified-name
                               ,docstring

M test/fugue.janet => test/fugue.janet +8 -5
@@ 151,6 151,8 @@

    (is (thrown? (size Dog)))
    (is (= "Fido" (name a-pekingese)))
    (is (= "Fido" (Pekingese-name a-pekingese)))

    (is (= "Extremely Small" (size a-pekingese)))

    (is (Pekingese? a-pekingese))


@@ 161,7 163,8 @@
    (is (Dog*? a-pekingese))
    (is (Dog*? Pekingese))

    (is (= "blue" (collar-color a-pekingese)))))
    (is (= "blue" (collar-color a-pekingese)))
    (is (= "blue" (Pekingese-collar-color a-pekingese)))))

(fugue/defproto Form () unique-field {:getter get-unique-field})



@@ 349,10 352,10 @@
(deftest slots-test
  (let [a-slot-haver (:new SlotHaver)]
    (fugue/with-slots SlotHaver a-slot-haver
      (set @name "will shortz")
      (is (= "will shortz" @name))
      (is (= "will shortz" (this :name)))
      (is (= "will shortz" (name this))))
                      (set @name "will shortz")
                      (is (= "will shortz" @name))
                      (is (= "will shortz" (this :name)))
                      (is (= "will shortz" (name this))))
    (is (= "will shortz" (a-slot-haver :name)))))

(deftest slots-validation

M test/namespaces.janet => test/namespaces.janet +1 -1
@@ 4,7 4,7 @@
(import /test-support/a)
(import /test-support/b)

(deftest multiple-file-multi-extend 
(deftest multiple-file-multi-extend
  (is (= 11 (a/f 10))))

(deftest namespaced-allocations