(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
#
(def- proto-field-registry
"Keep compile-time track of field definitions"
@{})
(defn- registry-fields
[sym]
(get-in proto-field-registry [sym]))
(defn- registry-register
[key value]
(put proto-field-registry key value))
#
# Bootstrapping
#
(defn- base-proto
"Basic prototype table."
[name defined-fields instance-defaults proto-allocated-fields & kvs]
(table
:_meta @{:object-type :prototype
:fields defined-fields
:prototype-allocations proto-allocated-fields
:instance-defaults instance-defaults
:getters @{}}
:_name name
;kvs))
(def Root
"Root of the Fugue object hierarchy."
(base-proto "Prototype" [] @{} @{} :_init identity))
#
# Field Access
#
(defn fields
```
Return all the defined fields for `obj` and its prototype
hierarchy.
```
[obj]
(let [proto-fields ;(if (table? obj)
(fields (table/getproto obj))
@[])
obj-fields (or (get-in obj [:_meta :fields]) @[])]
(array ;proto-fields ;obj-fields)))
(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 (if-let [reg-key (string (dyn :current-file) "-" obj)
listing (registry-fields reg-key)]
listing
(compiler-warn (string "no prototype definition found for " obj)))))
#
# Field Validation
#
(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)))
(defn- validate-proto-match
[name attrs]
(let [fields (comp-aware-fields name)]
(loop [k :keys attrs]
(validate-field k fields))))
(defn- warn-proto-method-shadow
[name proto]
(when (index-of (keyword name) (comp-aware-fields 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)))))
#
# defproto Forms
#
(defn- proto-docstring
[name defined-fields]
(string/format
"%s Prototype.\nFields: %q"
(string name)
((comp freeze (partial map symbol)) defined-fields)))
(defn- field-definitions
[name fields defined-fields]
(let [field-definitions @{:init-args @[]
:proto-allocated-fields @{}
:proto-allocations @{}
:instance-defaults @{}
:getters @{}}]
(registry-register (string (dyn :current-file) "-" name) defined-fields)
(loop [entry :in fields
:when (= 2 (length entry))
:let [[field-name attrs] entry
key-field (keyword field-name)]]
# Assemble list of arguments to constructor
(when (attrs :init?)
(array/push (field-definitions :init-args) field-name))
# Assemble fields that should be set directly on this prototype
(when (= (attrs :allocation) :prototype)
(put-in field-definitions [:proto-allocated-fields key-field] true))
# Assemble values to be set directly on prototype
(when-let [proto-value (attrs :allocate-value)]
(put-in field-definitions [:proto-allocations key-field] proto-value))
# Assemble mapping of fields to default values for instances
(when-let [default-value (attrs :default)]
(put-in field-definitions [:instance-defaults key-field] default-value))
# Assemble mapping of fields to getters (unless excluded)
(when-let [getter-name (match attrs
{:getter getter} getter
_ field-name)]
(put-in field-definitions [:getters field-name] getter-name)))
field-definitions))
(defn- prototype-attributes
[name attrs]
(let [prototype-attributes @{}]
(when-let [constructor-name (match attrs
{:constructor constructor-name} constructor-name
_ (symbol "new-" name))]
(put prototype-attributes :constructor-name constructor-name))
prototype-attributes))
(defn- proto-form
"Generate the def form for a Prototype."
[name parent fields defined-fields
{:proto-allocated-fields proto-allocated-fields
:proto-allocations to-allocate
:instance-defaults instance-defaults}]
~(let [parent (if (symbol? ',parent) ,parent ',Root)]
(->
',name
(,string)
(,base-proto
,defined-fields
,instance-defaults
,proto-allocated-fields
;(,kvs ,to-allocate))
(,table/setproto parent))))
(defn- init-form
"Generate the form that puts the object constructor method."
[name init-args]
~(fn ,(symbol "new-from-" name)
[self ,;init-args &keys attrs]
(let [inst @{:_meta @{:object-type :instance}}]
# 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])]
(loop [[default-key default-value] :pairs defaults]
(,put inst default-key default-value)))
# Recurse to grandparent
(set source-of-defaults (,table/getproto source-of-defaults)))
# Set positional values passed to constructor
(let [kvs (->> ,init-args
(,interleave ',init-args)
(,partition 2))]
(each [arg-name arg] kvs
(,put inst (,keyword arg-name) arg)))
# Set additional attributes passed to constructor
(,merge-into inst attrs)
# Associate instance with Prototype
(,table/setproto inst self)
(:_init inst))))
(put Root :new (eval (init-form 'Root [])))
(defn get-type-or-proto
```
Return the prototype of `obj`, if it has one, otherwise the keyword
output of `type`.
```
[obj]
(if (table? obj) (table/getproto obj) (type obj)))
(defn- pred-name [name] (symbol name "?"))
(defn- prototype-check
"Check if obj is an instance of proto."
[proto obj]
(and (table? obj) (= proto (table/getproto obj))))
(defn- pred-form
"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))]
~(defn ,pred-name
,pred-docstring
[obj]
(,prototype-check ,name obj))))
(eval (pred-form 'Root))
(defn- recursive-prototype-check
"Check if obj is a descendent of ancestor."
[ancestor obj]
(or (prototype-check ancestor obj)
(and (table? obj) (recursive-prototype-check ancestor (table/getproto obj)))))
(defn- pred*-form
"Generate the defn form for the recursive Prototype predicate."
[name]
(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))]
~(defn ,rec-pred-name
,rec-pred-docstring
[obj]
(,recursive-prototype-check ,name obj))))
(eval (pred*-form 'Root))
(defn- new-form
"Generate the init form wrapper."
[name constructor-name]
(when constructor-name
(let [docstring (string/format "Constructor for %s. Return a new object with %s as the prototype."
(string name)
(string name))]
~(defn ,constructor-name
,docstring
[& rest]
(:new ,name ;rest)))))
(eval (new-form 'Root 'new-Root))
(defn- getters
[name {: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)]]
(with-syms [self]
~(defn ,getter-name
,docstring
[,self]
(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)))
(,in ,self ,key-field)))))
(defmacro defproto
````
Object prototype definition.
## Usage
`name` should be any symbol. The resulting prototype will be
named after it.
`parent-name` is required; it can be an existing prototype, *or*
some null-ish value. If null-ish (`nil` or `()` should make the most
sense...) the parent of the prototype will be set to `fugue/Root`.
`fields` should be 0 or more pairs of the following format:
`<field-name> <field-attributes>`
Where `field-name` is a field to define on the prototype and
`field-attributes` is a struct describing the field. The following
field attributes are currently recognized:
- `:default`: provide a default value for all new instances of this
prototype
- `:init?`: if truthy, then this field will be a required parameter
to the prototype 's constructor
- `:allocation`: if `:prototype`, then `fugue/allocate` will always act on
the prototype when putting this field.
- `:allocate-value`: this field will have this attribute set at the
prototype, so that any children without their own values will
inherit it.
- `:getter`: specify a name for the defined function to access this
field (by default, has the same name as the field). Specify `false`
to prevent a getter from being defined.
`defproto` will define a getter function for each of the defined
fields, unless `:getter` is false.
`defproto` will also create a `:new` method in the created
prototype. This will take as positional arguments all of the fields
specified as `init?`, and then accept in `&keys` format any other
attributes to set on this object.
The special method `:_init` will be called as the last step in the
`:new` constructor. It can be defined for a prototype (see
`defmethod`) to take a new instance and to make any arbitrary
mutations on the instance or prototype as part of object
instantiation. By default it simply returns the instance.
The value provided to a field's `:default` entry will be inserted
directly to the instance. Thus, mutable/referenced terms like tables
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>`.
---
An example usage:
```
repl:43:> (fugue/defproto Dog () name {:allocate-value "Fido"})
repl:44:> (fugue/defproto Pekingese Dog size {:default "Extremely Small"})
repl:45:> (fugue/defmethod speak Dog [self] (string "My name is " (self :name)))
repl:46:> (fugue/defmethod speak Pekingese [self] (string (prototype-method self) " and I am " (self :size)))
repl:47:> (speak (:new Pekingese))
"My name is Fido and I am Extremely Small"
```
````
[name parent-name & fields]
(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)
[prototype-attributes-entry] (if has-proto-attributes (last fields) [{}])
prototype-attributes (prototype-attributes name prototype-attributes-entry)]
@[~(def ,name
,(proto-docstring name defined-fields)
(->
,(proto-form name
parent-name
fields
defined-fields
field-definitions)
(,put :new ,(init-form name (field-definitions :init-args)))))
(pred-form name)
(pred*-form name)
(new-form name (prototype-attributes :constructor-name))
;(getters name field-definitions)]))
(defn prototype?
```
Is `obj` the result of a `defproto ` call?
```
[obj]
(and (Root*? obj)
(= :prototype (get-in obj [:_meta :object-type]))))
(defn allocate
```
Allocation-aware put. If `obj` has inherited an allocation to a
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.
```
[obj key value]
(var source-of-defaults obj)
(while source-of-defaults
(let [prototype-allocations (get-in source-of-defaults [:_meta :prototype-allocations])]
(if (and prototype-allocations (in prototype-allocations key)) (break))
# Recurse to grandparent
(set source-of-defaults (table/getproto source-of-defaults))))
(let [dest (or source-of-defaults obj)]
(put dest key value)))
(def- raise-sentinel (gensym))
(defn- defgeneric*
[name docstring args & body]
(default docstring "Generic function.")
(with-syms [wrapper-args]
(let [err-msg (string/format
"could not apply generic %s to args %%q"
(string name))
method-name (keyword name)
final-case (case body
[raise-sentinel] ~(,errorf
,err-msg
,wrapper-args)
~(fn ,args ,;body))]
~(defn ,name
,docstring
[& ,wrapper-args]
(match (,first ,wrapper-args)
({,method-name f} (function? f)) (f ;,wrapper-args)
_ (,final-case ;,wrapper-args))))))
(defmacro defgeneric
```
Define a generic function. When this function is called, if the
first argument has a method corresponding to the name of the
function, call that object 's method with the arguments. Otherwise,
evaluate `body`.
```
[name & rest]
(let [[docstring args body]
(if (string? (first rest))
[(rest 0)
(rest 1)
(array/slice rest 2)]
[nil
(rest 0)
(array/slice rest 1)])]
(defgeneric* name docstring args ;(if (empty? body) [raise-sentinel] body))))
(defmacro defmethod
```
Simple single-dispatch method definition. Roughly equivalent to
`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`.
```
[name proto args & body]
(warn-proto-method-shadow name proto)
(upscope
(let [current-binding (dyn name)]
@[(unless (and current-binding (function? (current-binding :value)))
(compiler-info (string "Defining generic function for method " name "..."))
(defgeneric* name nil args raise-sentinel))
(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))))])))
#
# Multimethod Helpers
#
(defn- get-cases
[name store]
(as-> name .
(store .)
(pairs .)
# Total hack: rely on the fact that `nil` is the smallest
# value. Thus, when sorted, cases should always have the base
# case last for any positional argument.
#
# ie: [:string :string]
# [:string :_]
# [:_ :number]
# [:_ :_]
(sort . >)))
(defn- replace-placeholder-symbols
[types]
(defn f [sym]
(case sym
'_ nil
:_ nil
(let [evaled (eval sym)]
(if (not (or (table? evaled) (keyword? evaled)))
(errorf `Multimethod type error. Expected keyword or prototype, got:
%q of type %q`
sym
(type sym))
evaled))))
(tuple/slice (map f types)))
(defn- put-case
[name types fun store]
(let [types (replace-placeholder-symbols types)]
(put-in store [name types] fun)))
#
# Multimethod Closures
#
(def- multi-cases @{})
(defn- set-multi-default
[name]
(unless (in multi-cases name)
(put multi-cases name @{})))
(defn- put-multi-case
[name types fun]
(put-case name types fun multi-cases))
(defn- get-multi-cases
[name]
(get-cases name multi-cases))
#
# Open Multi Closures
#
(def- var-cases @{})
(defn- put-var-case
[f types fun]
(put-case f types fun var-cases))
(defn- get-var-cases
[name]
(get-cases name var-cases))
#
# Multimethod API
#
(defn multimethod-types-match?
```
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)
```
[args arg-types]
(if (not= (length arg-types) (length args))
false
(do
(var kk nil)
(var vk nil)
(var res true)
(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)
(= (get-type-or-proto (args kk)) (arg-types vk)))
(set res false)
(break)))
res)))
(defn- construct-cond
"Build main function logic of multimethod"
[name cases args-symbol]
(defn cond-case
[[case-types case]]
~[(,multimethod-types-match? ,args-symbol ',case-types)
(,case ;,args-symbol)])
(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))))
(defn- make-docstring
"Compose docstring for multimethod"
[cases &opt prefix]
(default prefix "")
(as->
(partial string/format "- %q") .
(comp . 0)
(map . cases)
(string/join . "\n\n")
(string prefix "Multimethod. Defined types:\n\n" .)))
(defn- emit-defn
"Generate defn form of multimethod"
[name docstring args cond-form]
~(defn ,name
,docstring
[& ,args]
,cond-form))
(defn- find-root
[t]
(cond
(table/rawget t :ref) t
(table/getproto t) (find-root (table/getproto t))
nil))
(defn- emit-varfn
"Generate varfn form of multimethod"
[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)
f))
(defn- make-case
[args body]
(eval ~(fn ,args ,;body)))
(defmacro defmulti
````
Define a multimethod based on all the arguments passed to the
function.
Example usage :
```
> (defproto Foo ())
> (defmulti add [Foo] [f] (put f :value 1))
> (defmulti add [:number] [x] (+ x 1))
> (defmulti add [:string] [s] (string s "!"))
> (def a-foo (:new Foo))
> (add a-foo)
@Foo{:value 1 :_meta @{:object-type :instance}}
> (add 1)
2
> (add "s")
"s!"
```
`defmulti` takes a sequence of type-or-prototypes, and builds a
function which will check its arguments against those types (as well
as all other ones specified in other `defmulti` calls to the same
function name), and execute the function body for the matching type
signature.
In addition to type names or prototypes, you can use the symbol `_`
or keyword `:_` as a wildcard that means "match any type". For
instance,
```
repl:2:> (defmulti cat [:string :_] [s1 s2] (string s1 s2))
repl:3:> (cat "hello " "world!")
"hello world!"
repl:4:> (cat "hello " 42)
"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
```
Defining a multimethod with the signature `[:string :_]` will match
on any two arguments if the first one is a string.
A multimethod without wilcards will be preferred to one with one in
the same position. For instance, if we define an additional
multimethod:
```
repl:8:> (defmulti cat [:string :number] [s n] (string s " #" n))
```
Then that more specific method will be preferred and the wildcard
will be a fallback if the specific one doesn't match:
```
repl:10:> (cat "hello " @"world")
"hello world"
repl:12:> (cat "hello" 100)
"hello #100"
```
````
[name multi-types args & body]
# Nominal case handling: group declared cases by concating the
# 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))
(with-syms [args]
(let [cases (get-multi-cases cases-key)
cond-form (construct-cond (string name) cases args)
docstring (make-docstring cases)]
(emit-defn name docstring args cond-form)))))
(defmacro declare-open-multi
```
Declare an open multimethod, ie, one that can be extended.
Extending an open multimethod (see `extend-multi`) from any other
environment makes the case extension available wherever the
multimethod has been imported.
```
[name]
(let [f (eval ~(fn ,name [& _] (error "No cases declared for open multimethod")))
ref @[f]
cell @{:doc "Open multimethod." :ref ref}]
(put var-cases ref @{})
(setdyn name cell)
f))
(defmacro extend-multi
```
Extend an open multimethod (see `declare-open-multi`) using the same
syntax as `defmulti`.
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.
```
[multi multi-types args & body]
(let [ref (and (dyn multi) (in (dyn multi) :ref))]
(put-var-case ref multi-types (make-case args body))
(with-syms [args]
(let [cases (get-var-cases ref)
fn-name (->> multi (string/split "/") (last))
cond-form (construct-cond fn-name cases args)
docstring (make-docstring cases "Open ")]
(emit-varfn multi (symbol fn-name) docstring args cond-form)))))
(defn- field-transformer
[fields obj-sym as proto-name]
(fn [sym]
(cond
(and (tuple? sym) (= (length sym) 2) (= (sym 0) as) (symbol? (sym 1)))
(let [field-name (-> sym (1) (keyword))]
(unless (index-of field-name fields)
(errorf `Encountered field reference %q for prototype %q;
Expected one of: %q`
sym
proto-name
fields))
~(,obj-sym ,field-name))
(= sym as)
obj-sym
true
sym)))
(defn- do-with-slots-as
[proto obj as body]
(with-syms [x]
(let [f (-> proto (eval) (fields) (field-transformer x as proto))]
~(let [,x ,obj]
,;(prewalk f body)
,x))))
(defmacro with-slots
````
Anaphoric macro with transformed getter/setters.
Introduces two useful forms for referring to `obj`.
It introduces a *reference symbol* - `@` by default
(see `with-slots-as `to specify the symbol).
The pattern `(@ <field name>)`, where `<field name>` is a symbol, is
transformed into `(obj (keyword <field name>))`, if and only if
`<field name>` is defined for `proto`, so that `(@ name)` or its
setter form `(set (@ name) foo)` do the right thing.
The reference symbol by itself is introduces as a reference to
`obj`.
Returns `obj`.
---
Example :
```
repl:2:> (defproto Foo nil name {:default "Jane Doe"})
repl:4:> (with-slots Foo (new-Foo)
(set (@ name) "Cosmo Kramer")
(print (@ name))
(print (Foo? @)))
Cosmo Kramer
true
@Foo{:_meta @{:object-type :instance} :name "Cosmo Kramer"}
```
````
[proto obj & body]
(do-with-slots-as proto obj '@ body))
(defmacro with-slots-as
```
Anaphoric macro with transformed getter/setters.
Specifies `as` as the reference symbol for `with-slots`.
See `with-slots` documentation for more details.
```
[proto obj as & body]
(do-with-slots-as proto obj as body))
(defmacro @
```
Compile-time Prototype field checking.
Accepts two forms:
`(@ SomePrototype :some-field)` - Translates into `:some-field`, if
`some-field` is defined on `SomePrototype`.
`(@ 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)`.
```
[proto x &opt y]
(let [[obj field] (if y [x y] [nil x])
fields (fields (eval proto))]
(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)))))
(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)))
pattern)
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)))