~subsetpark/fugue

64338cf5dc71b82ec80b0773357cd5767f0c28e3 — Zach Smith 25 days ago 1ee8fca
Add fugue/match
3 files changed, 134 insertions(+), 43 deletions(-)

M README.md
M fugue.janet
M test/fugue.janet
M README.md => README.md +41 -25
@@ 61,7 61,7 @@ be selected for any descendent prototype instances.

## fugue

[@](#), [Root](#Root), [Root*?](#Root-1), [Root?](#Root-2), [allocate](#allocate), [declare-open-multi](#declare-open-multi), [defgeneric](#defgeneric), [defmethod](#defmethod), [defmulti](#defmulti), [defproto](#defproto), [extend-multi](#extend-multi), [fields](#fields), [get-type-or-proto](#get-type-or-proto), [multimethod-types-match?](#multimethod-types-match), [new-Root](#new-Root), [prototype?](#prototype), [with-slots](#with-slots), [with-slots-as](#with-slots-as)
[@](#), [Root](#Root), [Root*?](#Root-1), [Root?](#Root-2), [allocate](#allocate), [declare-open-multi](#declare-open-multi), [defgeneric](#defgeneric), [defmethod](#defmethod), [defmulti](#defmulti), [defproto](#defproto), [extend-multi](#extend-multi), [fields](#fields), [get-type-or-proto](#get-type-or-proto), [match](#match), [multimethod-types-match?](#multimethod-types-match), [new-Root](#new-Root), [prototype?](#prototype), [with-slots](#with-slots), [with-slots-as](#with-slots-as)

## @



@@ 81,10 81,9 @@ Accepts two forms:
`(@ SomePrototype some-object :some-field)` - Asserts (as above) at
compile time that `some-field` is defined on `SomePrototype`; at
runtime, checks that `some-object` is a descendent of
`SomePrototype` and if so, translates to `(some-object
:some-field)`.
`SomePrototype` and if so, translates to `(some-object :some-field)`.

[1]: fugue.janet#L754
[1]: fugue.janet#L797

## Root



@@ 96,7 95,7 @@ runtime, checks that `some-object` is a descendent of

Root of the Fugue object hierarchy.

[2]: fugue.janet#L15
[2]: fugue.janet#L40

## Root*?



@@ 137,7 136,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.

[5]: fugue.janet#L335
[5]: fugue.janet#L362

## declare-open-multi



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

[6]: fugue.janet#L640
[6]: fugue.janet#L676

## defgeneric

**macro**  | [source][7]

```janet
(defgeneric name args &opt body)
(defgeneric name & rest)
```

Define a generic function. When this function is called, if the


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

[7]: fugue.janet#L371
[7]: fugue.janet#L399

## defmethod



@@ 186,7 185,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`.

[8]: fugue.janet#L382
[8]: fugue.janet#L417

## defmulti



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

[9]: fugue.janet#L564
[9]: fugue.janet#L600

## defproto



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

[10]: fugue.janet#L232
[10]: fugue.janet#L259

## extend-multi



@@ 358,7 357,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.

[11]: fugue.janet#L656
[11]: fugue.janet#L692

## fields



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

[12]: fugue.janet#L21
[12]: fugue.janet#L50

## get-type-or-proto



@@ 384,11 383,28 @@ hierarchy.
Return the prototype of `obj`, if it has one, otherwise the keyword
output of `type`.

[13]: fugue.janet#L146
[13]: fugue.janet#L173

## match

**macro**  | [source][14]

```janet
(match x & cases)
```

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. 

[14]: fugue.janet#L831

## multimethod-types-match?

**function**  | [source][14]
**function**  | [source][15]

```janet
(multimethod-types-match? args arg-types)


@@ 398,11 414,11 @@ 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)

[14]: fugue.janet#L489
[15]: fugue.janet#L525

## new-Root

**function**  | [source][15]
**function**  | [source][16]

```janet
(new-Root & rest)


@@ 410,11 426,11 @@ and using `:_` as a fallback)

Constructor for Root. Return a new object with Root as the prototype.

[15]: eval#L-1
[16]: eval#L-1

## prototype?

**function**  | [source][16]
**function**  | [source][17]

```janet
(prototype? obj)


@@ 422,11 438,11 @@ Constructor for Root. Return a new object with Root as the prototype.

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

[16]: fugue.janet#L327
[17]: fugue.janet#L354

## with-slots

**macro**  | [source][17]
**macro**  | [source][18]

```janet
(with-slots proto obj & body)


@@ 464,11 480,11 @@ true
@Foo{:_meta @{:object-type :instance} :name "Cosmo Kramer"}
```

[17]: fugue.janet#L706
[18]: fugue.janet#L742

## with-slots-as

**macro**  | [source][18]
**macro**  | [source][19]

```janet
(with-slots-as proto obj as & body)


@@ 480,5 496,5 @@ Specifies `as` as the reference symbol for `with-slots`.

See `with-slots` documentation for more details.

[18]: fugue.janet#L743
[19]: fugue.janet#L779


M fugue.janet => fugue.janet +64 -11
@@ 1,3 1,12 @@
(defn- compiler-emit
  [level msg]
  (let [source (or (dyn :current-file) "n/a")
        [l c] (tuple/sourcemap (dyn :macro-form ()))]
    (eprintf "%s:%i:%i: [%s] %s" source l c level msg)))

(defn- compiler-warn [msg] (compiler-emit "WARNING" msg))
(defn- compiler-info [msg] (compiler-emit "INFO" msg))

#
# Compile-time field access
#


@@ 56,8 65,10 @@
  (cond
    (not (symbol? obj)) (fields obj)
    (dyn obj) (fields (eval obj))
    true (let [reg-key (string (dyn :current-file) "-" obj)]
           (or (registry-fields reg-key) @[]))))
    true (if-let [reg-key (string (dyn :current-file) "-" obj)
                  listing (registry-fields reg-key)]
           listing
           (compiler-warn (string "no prototype definition found for " obj)))))

#
# defproto Forms


@@ 320,7 331,7 @@
  ```
  ````
  [name parent-name & fields]
  (let [has-proto-attributes (not (zero? (mod (length fields) 2)))
  (let [has-proto-attributes (odd? (length fields))
        fields (partition 2 fields)
        defined-fields (map (comp keyword 0) (if has-proto-attributes (array/slice fields 0 -2) fields))
        field-definitions (field-definitions name fields defined-fields)


@@ 415,13 426,14 @@
  ```
  [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)))
    (compiler-warn
      (string/format "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)))
          (print "Defining generic function for method " name "...")
          (compiler-info (string "Defining generic function for method " name "..."))
          (defgeneric* name nil args raise-sentinel))

        (let [method-name (keyword name)


@@ 775,6 787,13 @@
  [proto obj as & body]
  (do-with-slots-as proto obj as body))

(defn- validate-field
  [field fields]
  (unless fields
    (errorf "Field validation for `%s` failed; no fields registered" (string field)))
  (unless (index-of field fields)
    (errorf "Field `%s` not found; got fields: %q" (string field) fields)))

(defmacro @
  ```
  Compile-time Prototype field checking.


@@ 787,18 806,52 @@
  `(@ SomePrototype some-object :some-field)` - Asserts (as above) at
  compile time that `some-field` is defined on `SomePrototype`; at
  runtime, checks that `some-object` is a descendent of
  `SomePrototype` and if so, translates to `(some-object
  :some-field)`.
  `SomePrototype` and if so, translates to `(some-object :some-field)`.
  ```
  [proto x &opt y]
  (let [[obj field] (if y [x y] [nil x])
        fields (fields (eval proto))]

    (unless (index-of field fields)
      (errorf "Field `%s` not found; got fields: %q" (string field) fields))
    (validate-field field fields)

    (if-not obj
      field
      ~(if-not (,recursive-prototype-check ,proto ,obj)
         (errorf "Expected a %s, got: %q" ,(string proto) (,get-type-or-proto ,obj))
         ,(tuple obj field)))))

(defn- validate-proto-match
  [name attrs]
  (let [fields (comp-aware-fields name)]
    (loop [k :keys attrs]
      (validate-field k fields))))

(def- root-match match)

(defmacro match
  ```
  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. 
  ```
  [x & cases]
  (defn transform
    [[pattern exp]]
    [(match pattern
       @[(@ '@) proto-name attrs]
       (do
         (validate-proto-match proto-name attrs)
         (struct ;(kvs attrs) :_name (string proto-name)))

       p p)
     exp])
  
  (let [oddlen (odd? (length cases))
        else (if oddlen (last cases))
        patterns (partition 2 (if oddlen (slice cases 0 -2) cases))
        transformed (mapcat transform patterns)
        cases (if else (array/push transformed else) transformed)]
    (root-match x ;cases)))

M test/fugue.janet => test/fugue.janet +29 -7
@@ 382,11 382,11 @@

(deftest defmethod-warning
  (def buffer @"")
  (with-dyns [:out buffer]
  (with-dyns [:err 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"
  (is (string/has-suffix?
        "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


@@ 396,12 396,11 @@
  (fugue/defproto ShadowInTest nil height {})

  (def buffer @"")
  (with-dyns [:out buffer]
  (with-dyns [:err 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)))
  (is (string/has-suffix? "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))


@@ 462,4 461,27 @@
    (is (= "Brian May" (a-slot-haver :name)))
    (is (thrown? (fugue/@ SlotHaver not-a-member-of-queen :name)))))

(fugue/defproto MyMatcher nil name {})

(deftest fugue-match
  (defn try-match [obj]
    (fugue/match obj
                 (@ MyMatcher {:name some-name}) (string some-name "!")
                 {:name some-name} (string some-name ".")))
  (is (= "Matcher!" (try-match (new-MyMatcher :name "Matcher"))))
  (is (= "Non-Matcher." (try-match {:name "Non-Matcher"}))))

(deftest fugue-match-warnings
  (is (thrown?
        "Field `some-other-field` not found; got fields: @[:name]"
        (apply fugue/match '[:ok (@ MyMatcher {:some-other-field foo}) foo]))))

(deftest fugue-match-else
  (defn try-match [obj]
    (fugue/match obj
                 (@ MyMatcher {:name some-name}) (string some-name "!")
                 (string obj ".")))
  (is (= "Matcher!" (try-match (new-MyMatcher :name "Matcher"))))
  (is (= "Non-Matcher." (try-match "Non-Matcher"))))

(run-tests!)