~subsetpark/fugue

0ffb9b6dffa9cd93f600400c02d5a7e2bacafe33 — Zach Smith 6 months ago 3b9b508
Unquote a bunch of stlib functions
2 files changed, 66 insertions(+), 55 deletions(-)

M README.md
M fugue.janet
M README.md => README.md +12 -12
@@ 112,7 112,7 @@ specific prototype for this key, then `fugue/allocate` will put `value`
at `key` in the appropriate prototype, and it will be inherited by
all descendents of that prototype.

[4]: fugue.janet#L287
[4]: fugue.janet#L293

## declare-open-multi



@@ 128,7 128,7 @@ Extending an open multimethod (see `extend-multi`) from any other
environment makes the case extension available wherever the
multimethod has been imported.

[5]: fugue.janet#L600
[5]: fugue.janet#L606

## defgeneric



@@ 143,7 143,7 @@ first argument has a method corresponding to the name of the
function, call that object 's method with the arguments. Otherwise,
evaluate `body`.

[6]: fugue.janet#L321
[6]: fugue.janet#L329

## defmethod



@@ 161,7 161,7 @@ Defines a few symbols for reference in the body of the method.
`__parent` - Bound to the parent of `proto`.
`__super` - Bound to the method at `name` within `__parent`.

[7]: fugue.janet#L332
[7]: fugue.janet#L340

## defmulti



@@ 233,7 233,7 @@ repl:12:> (cat "hello" 100)
"hello #100"
```

[8]: fugue.janet#L524
[8]: fugue.janet#L530

## defproto



@@ 313,7 313,7 @@ repl:47:> (speak (:new Pekingese))
"My name is Fido and I am Extremely Small"
```

[9]: fugue.janet#L182
[9]: fugue.janet#L188

## extend-multi



@@ 331,7 331,7 @@ See that function's documentation for full usage reference.
Whenever a case is added to `multi`, that case is available
wherever the multimethod is imported.

[10]: fugue.janet#L616
[10]: fugue.janet#L622

## fields



@@ 344,7 344,7 @@ wherever the multimethod is imported.
Return all the defined fields for `obj` and its prototype
hierarchy.

[11]: fugue.janet#L359
[11]: fugue.janet#L367

## get-type-or-proto



@@ 371,7 371,7 @@ Check to see if the types `args` match the sequence `arg-types`,
according to multimethod rules (ie, following prototype membership
and using `:_` as a fallback)

[13]: fugue.janet#L452
[13]: fugue.janet#L455

## new-Root



@@ 395,7 395,7 @@ and using `:_` as a fallback)

Is `obj` the result of a `defproto ` call? 

[15]: fugue.janet#L279
[15]: fugue.janet#L285

## with-slots



@@ 428,7 428,7 @@ true
nil
```

[16]: fugue.janet#L658
[16]: fugue.janet#L664

## with-slots-as



@@ 447,5 447,5 @@ so that `@name` or its setter form `(set @name foo)` do the right thing.

See `with-slots` documentation for more details.

[17]: fugue.janet#L686
[17]: fugue.janet#L692


M fugue.janet => fugue.janet +54 -43
@@ 55,15 55,15 @@
  "Generate the def form for a Prototype."
  [name parent fields defined-fields
   _init-args proto-allocated-fields proto-allocations instance-defaults]
  ~(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])))
  ~(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)
     (merge-into object ',proto-allocations)
     (table/setproto object ',parent)))
     (,put-in object [:_meta :instance-defaults] ',instance-defaults)
     (,merge-into object ',proto-allocations)
     (,table/setproto object ',parent)))

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


@@ 75,24 75,24 @@
       # 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])]
         (let [defaults (,get-in source-of-defaults [:_meta :instance-defaults])]
           (loop [[default-key default-value] :pairs defaults]
             (put inst default-key default-value)))
             (,put inst default-key default-value)))
         # Recurse to grandparent
         (set source-of-defaults (table/getproto source-of-defaults)))
         (set source-of-defaults (,table/getproto source-of-defaults)))

       # Set positional values passed to constructor
       (let [kvs (->> ,init-args
                      (interleave ',init-args)
                      (partition 2))]
                      (,interleave ',init-args)
                      (,partition 2))]
         (each [arg-name arg] kvs
           (put inst (keyword arg-name) arg)))
           (,put inst (,keyword arg-name) arg)))

       # Set additional attributes passed to constructor
       (merge-into inst attrs)
       (,merge-into inst attrs)

       # Associate instance with Prototype
       (table/setproto inst self)
       (,table/setproto inst self)

       (:_init inst))))



@@ 118,8 118,10 @@
                          instance (that is, a direct child) of %s.
                          ```
                         (string name))]
    ~(defn ,pred-name ,pred-docstring [obj]
       (and (table? obj) (= ,name (table/getproto obj))))))
    ~(defn ,pred-name
       ,pred-docstring
       [obj]
       (and (,table? obj) (,= ,name (,table/getproto obj))))))

(eval (pred-form 'Root))



@@ 135,9 137,11 @@
                              descendent of %s.
                              ```
                             (string name))]
    ~(defn ,rec-pred-name ,rec-pred-docstring [obj]
    ~(defn ,rec-pred-name
       ,rec-pred-docstring
       [obj]
       (or (,pred-name obj)
           (and (table? obj) (,rec-pred-name (table/getproto obj)))))))
           (and (,table? obj) (,rec-pred-name (,table/getproto obj)))))))

(eval (pred*-form 'Root))



@@ 145,7 149,9 @@
  "Generate the init form wrapper."
  [name]
  (let [init-name (symbol "new-" name)]
    ~(defn ,init-name [& rest] (:new ,name ;rest))))
    ~(defn ,init-name
       [& rest]
       (:new ,name ;rest))))

(eval (new-form 'Root))



@@ 165,7 171,7 @@
          (array/push forms ~(defn ,getter-name
                               ,docstring
                               [,self]
                               (in ,self ,key-field)))
                               (,in ,self ,key-field)))
          (array/push forms ~(defn ,qualified-name
                               ,docstring
                               [,self]


@@ 173,10 179,10 @@
                                 (let [found-name (match (,get-type-or-proto ,self)
                                                    @{:_name name} name
                                                    type type)]
                                   (errorf "type error: expected %q, got: %q"
                                           ',name
                                           found-name)))
                               (in ,self ,key-field))))))
                                   (,errorf "type error: expected %q, got: %q"
                                      ',name
                                      found-name)))
                               (,in ,self ,key-field))))))
    forms))

(defmacro defproto


@@ 270,7 276,7 @@
                        fields
                        defined-fields
                        ;field-definitions)
           (put :new ,(init-form name init-args))))
           (,put :new ,(init-form name init-args))))
      (pred-form name)
      (pred*-form name)
      (new-form name)


@@ 309,12 315,14 @@
                    (string name))
          method-name (keyword name)
          final-case (case body
                       [raise-sentinel] ~(errorf
                                           ,err-msg
                                           ,wrapper-args)
                       [raise-sentinel] ~(,errorf
                                            ,err-msg
                                            ,wrapper-args)
                       ~(fn ,args ,;body))]
      ~(defn ,name [& ,wrapper-args]
         (match (first ,wrapper-args)
      ~(defn ,name
         "Generic function."
         [& ,wrapper-args]
         (match (,first ,wrapper-args)
           ({,method-name f} (function? f)) (f ;,wrapper-args)
           _ (,final-case ;,wrapper-args))))))



@@ 348,13 356,13 @@

        (let [method-name (keyword name)
              full-method-name (symbol proto "-" name)]
          ~(put ,proto
                ,method-name
                (fn ,full-method-name
                  ,args
                  (let [__parent (table/getproto ,proto)
                        __super (__parent ,method-name)]
                    ,;body))))])))
          ~(,put ,proto
              ,method-name
              (fn ,full-method-name
                ,args
                (let [__parent (table/getproto ,proto)
                      __super (__parent ,method-name)]
                  ,;body))))])))

(defn fields
  ```


@@ 478,7 486,7 @@

  (let [body (mapcat cond-case cases)
        err-msg (string/format "could not apply multimethod %s to args %%q" name)]
    ~(cond ,;body (errorf ,err-msg ,args-symbol))))
    ~(cond ,;body (,errorf ,err-msg ,args-symbol))))

(defn- make-docstring
  "Compose docstring for multimethod"


@@ 494,7 502,10 @@
(defn- emit-defn
  "Generate defn form of multimethod"
  [name docstring args cond-form]
  ~(defn ,name ,docstring [& ,args] ,cond-form))
  ~(defn ,name
     ,docstring
     [& ,args]
     ,cond-form))

(defn- find-root
  [t]


@@ 508,8 519,8 @@
  [name fn-name docstring args cond-form]
  ~(let [cell (,find-root (dyn ',name))
         f (fn ,fn-name [& ,args] ,cond-form)]
     (put-in cell [:ref 0] f)
     (put-in cell [:doc] ,docstring)
     (,put-in cell [:ref 0] f)
     (,put-in cell [:doc] ,docstring)
     f))

(defn- make-case