mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
102 lines
3.1 KiB
Plaintext
102 lines
3.1 KiB
Plaintext
; Implementors’ note: this code could be made more elegant by using quasiquotes
|
||
; but quasiquoting is actually loaded after this module, so we can’t rely on
|
||
; that functionality.
|
||
|
||
|
||
(doc Derive "is a mechanism for deriving interfaces automatically.
|
||
|
||
Please reference [the documentation](https://github.com/carp-lang/Carp/blob/master/docs/Derive.md)
|
||
for more information.")
|
||
(defmodule Derive
|
||
(hidden derivers)
|
||
(defdynamic derivers '())
|
||
|
||
(doc make-deriver "is a mechanism for providing your own deriver by providing
|
||
the interface name `f`, the arguments it takes `args`, and a function that can
|
||
generate a body when given a type `body`.
|
||
|
||
Example:
|
||
```
|
||
(make-deriver 'zero []
|
||
(fn [t]
|
||
(cons 'init
|
||
(map (fn [_] '(zero)) (eval `(members %t)))))
|
||
```")
|
||
(defndynamic make-deriver [f args body]
|
||
(set! Derive.derivers
|
||
(cons
|
||
(list f
|
||
(fn [t name]
|
||
(list 'defmodule t
|
||
(list 'defn name args
|
||
(body t))
|
||
(list 'implements f (Symbol.prefix t name)))))
|
||
Derive.derivers)))
|
||
|
||
(doc make-update-deriver "is a convenience function for creating a deriver
|
||
for functions that you could pass into `update-<member>` style functions.")
|
||
(defndynamic make-update-deriver [interface]
|
||
(make-deriver interface ['o]
|
||
(fn [t]
|
||
(reduce
|
||
(fn [acc m]
|
||
(list (Symbol.concat ['update- (car m)]) acc (list 'ref interface)))
|
||
'o
|
||
(eval (list 'members t))))))
|
||
|
||
(hidden get-deriver)
|
||
(defndynamic get-deriver [f derivers]
|
||
(if (empty? derivers)
|
||
'()
|
||
(if (= (caar derivers) f)
|
||
(car derivers)
|
||
(get-deriver f (cdr derivers)))))
|
||
|
||
(doc derivable? "checks whether a quoted interface name `f` is currently
|
||
derivable.")
|
||
(defndynamic derivable? [f]
|
||
(let [deriver (get-deriver f Derive.derivers)]
|
||
(not (empty? deriver))))
|
||
|
||
(doc derivables "returns the list of currently derivable interfaces.")
|
||
(defndynamic derivables []
|
||
(map car Derive.derivers))
|
||
|
||
(doc derive "derives an interface function `f` for a type `t`.
|
||
|
||
Optionally, it also takes an argument `overrride` that overrides the name of
|
||
the generated function to avoid collisions.")
|
||
(defmacro derive [t f :rest override]
|
||
(let [name (if (empty? override) f (car override))
|
||
deriver (get-deriver f Derive.derivers)]
|
||
(if (empty? deriver)
|
||
(macro-error (String.concat ["no deriver found for interface " (str f) "!"]))
|
||
(eval ((cadr deriver) t name))))))
|
||
|
||
(use Derive)
|
||
|
||
(make-deriver '= ['o1 'o2]
|
||
(fn [t]
|
||
(reduce
|
||
(fn [acc m]
|
||
(list 'and (list '= (list (car m) 'o1) (list (car m) 'o2)) acc))
|
||
true
|
||
(eval (list 'members t)))))
|
||
|
||
(make-deriver 'zero []
|
||
(fn [t]
|
||
(cons 'init
|
||
(map (fn [_] '(zero)) (eval (list 'members t))))))
|
||
|
||
(make-deriver 'str ['o]
|
||
(fn [t]
|
||
(let [mems (eval (list 'members t))]
|
||
(cons 'fmt
|
||
(cons
|
||
(String.concat
|
||
(append
|
||
(append ["(" (str t)]
|
||
(collect-into (map (fn [_] " %s") mems) array))
|
||
[")"]))
|
||
(map (fn [m] (list 'ref (list 'str (list (car m) 'o)))) mems))))))
|