~subsetpark/fugue

16a776c2adbd3626745f126d67cc2973143e921c — Zach Smith 2 months ago 4814bcf
Implement pattern destructuring in multimethod case body
2 files changed, 58 insertions(+), 27 deletions(-)

M fugue.janet
M test/fugue.janet
M fugue.janet => fugue.janet +45 -27
@@ 285,7 285,7 @@
  Object prototype definition.

  ## Usage
  

  `name` should be any symbol. The resulting prototype will be
  named after it.



@@ 333,16 333,16 @@
  and arrays will be shared amongst all instances. In cases where you
  want to insert a new term for each new instance, use the `_init`
  method to put a value at that field.
  

  If `fields` is of an odd length, the last element will be treated as
  a prototype attributes struct. There is currently one valid prototype attribute:

  - `:constructor` : Set the name of the defined function that
    calls `:new`. If false, no additional constructor will be
    defined. By default, will be set to `new-<prototype name>`.
  
  calls `:new`. If false, no additional constructor will be
  defined. By default, will be set to `new-<prototype name>`.

  ---
  

  An example usage:

  ```


@@ 455,7 455,7 @@
  `put` ing a function directly into a prototype.

  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`.
  ```


@@ 488,12 488,16 @@
        #     [:_ :_]
        (sort . >)))

(defn- compile-matcher
  [sym]
  (eval ~(fn [x] (match x ,sym true))))

(defn- replace-placeholder-symbols
  [types]
  (defn f [sym]
    (case sym
      '_ nil
      :_ nil
    (cond
      (or (= '_ sym) (= :_ sym)) nil
      (or (tuple? sym) (struct? sym)) (compile-matcher sym)
      (let [evaled (eval sym)]
        (if (not (or (table? evaled) (keyword? evaled)))
          (errorf `Multimethod type error. Expected keyword or prototype, got:


@@ 561,28 565,42 @@
      (while true
        (set kk (next args kk))
        (if (= nil kk) (break))

        (set vk (next arg-types vk))
        (if (= nil vk) (break))

        (unless (or (= (arg-types vk) nil)
                    (and (function? (arg-types vk))
                         ((arg-types vk) (args kk)))
                    (= (get-type-or-proto (args kk)) (arg-types vk)))
          (set res false)
          (break)))

      res)))

(defn- make-case
  [args body]
  (eval ~(fn ,args ,;body)))
  [multi-types args body]
  (let [destructurable @[]]
    (each [type arg] (map tuple multi-types args)
      (cond
        (struct? type) (array/concat destructurable @[type arg])
        (tuple? type) (array/concat destructurable @[(first type) arg])))
    (eval ~(fn multimethod-case
             ,args
             (let ,destructurable
               ,;body)))))

(defn- construct-cond
  "Build main function logic of multimethod"
  [name cases args-symbol]
  (defn cond-case
    [[case-types case]]
    [[case-types case-fn]]
    ~[(,multimethod-types-match? ,args-symbol ',case-types)
      (,case ;,args-symbol)])
      (,case-fn ;,args-symbol)])

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

(defn- make-docstring


@@ 643,8 661,8 @@
  "hello 42"
  repl:5:> (cat 42 "hello")
  error: could not apply multimethod <function cat> to args (42 "hello")
    in cat [repl] on line 2, column 1
    in _thunk [repl] (tailcall) on line 5, column 1
  in cat [repl] on line 2, column 1
  in _thunk [repl] (tailcall) on line 5, column 1
  ```

  Defining a multimethod with the signature `[:string :_]` will match


@@ 673,7 691,7 @@
  # 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))
    (put-multi-case cases-key multi-types (make-case multi-types args body))

    (with-syms [args]
      (let [cases (get-multi-cases cases-key)


@@ 724,7 742,7 @@
  ```
  [multi multi-types args & body]
  (let [ref (and (dyn multi) (in (dyn multi) :ref))]
    (put-var-case ref multi-types (make-case args body))
    (put-var-case ref multi-types (make-case multi-types args body))

    (with-syms [args]
      (let [cases (get-var-cases ref)


@@ 744,7 762,7 @@
          (unless (index-of field-name fields)
            (errorf `Encountered field reference %q for prototype %q;

                   Expected one of: %q`
                     Expected one of: %q`
                    sym
                    proto-name
                    fields))


@@ 780,7 798,7 @@
  `obj`.

  Returns `obj`.
  

  ---

  Example :


@@ 788,9 806,9 @@
  ```
  repl:2:> (defproto Foo nil name {:default "Jane Doe"})
  repl:4:> (with-slots Foo (new-Foo)
             (set (@ name) "Cosmo Kramer")
             (print (@ name))
             (print (Foo? @)))
  (set (@ name) "Cosmo Kramer")
  (print (@ name))
  (print (Foo? @)))
  Cosmo Kramer
  true
  @Foo{:_meta @{:object-type :instance} :name "Cosmo Kramer"}


@@ 841,9 859,9 @@
  Prototype-aware version of `match`. Introduces one new case form:

  - `(@ <prototype-name> <dictionary>)`: Will pattern match against an
    instance of `prototype-name`. Additionally, will validate at
    compile-time that every key in `dictionary` is a field that's
    present on the specified prototype. 
  instance of `prototype-name`. Additionally, will validate at
  compile-time that every key in `dictionary` is a field that's
  present on the specified prototype. 
  ```
  [x & cases]
  (defn transform

M test/fugue.janet => test/fugue.janet +13 -0
@@ 499,4 499,17 @@
  (is (= "Matcher!" (try-match (new-MyMatcher :name "Matcher"))))
  (is (= "Non-Matcher." (try-match "Non-Matcher"))))

(deftest matching-multis
  (fugue/defmulti with-matching 
                  [{:magic-key z}] [x] 
                  (inc (x :magic-key)))

  (fugue/declare-open-multi open-with-matching)
  (fugue/extend-multi open-with-matching 
                      [{:magicer-key z}] [x] 
                      (inc (x :magicer-key)))
  
  (is (= 1 (with-matching {:magic-key 0})))
  (is (= 1 (open-with-matching {:magicer-key 0}))))

(run-tests!)