Add meth and ameth

docs/index.rst

@@ -108,6 +108,13 @@ API
 .. hy:autofunction:: match-fn-params
 .. hy:automacro:: with-gensyms
 
+``oop`` — Tools for object-oriented programming
+----------------------------------------------------------------------
+.. hy:automodule:: hyrule.oop
+
+.. hy:automacro:: meth
+.. hy:automacro:: ameth
+
 ``pprint`` — Pretty-printing data structures
 ----------------------------------------------------------------------
 .. hy:automodule:: hyrule.hypprint

hyrule/hy_init.hy

@@ -6,6 +6,7 @@
   hyrule.destructure *
   hyrule.macrotools * :readers *
   hyrule.misc *
+  hyrule.oop *
   hyrule.sequences *)
 (import
   hyrule.collections *

hyrule/oop.hy

@@ -0,0 +1,66 @@
+(import
+  hyrule.macrotools [map-model])
+
+
+(defmacro meth [#* args]
+  #[[A replacement for :hy:func:`defn` that provides syntactic sugar for ``self``. As the name suggests, it's most useful for defining methods. The parameter list is automatically prepended with ``self``, and any reference to a symbol beginning with ``@``, such as ``@foo``, is replaced by ``self.foo``::
+
+    (defclass BirdWatcher []
+
+      (meth observe [bird]
+        (@log bird)
+        (setv @last-seen bird)
+        @last-seen)
+
+      (meth log [bird]
+        (print "I just saw:" bird)))
+
+    (setv x (BirdWatcher))
+    (.observe x "sparrow")   ; I just saw: sparrow
+    (.observe x "cardinal")  ; I just saw: cardinal
+    (print x.last-seen)      ; cardinal
+
+  ``@``-symbols that appear in the lambda list of the method are special: ``@foo`` is replaced with simply ``foo``, and the method body is prepended with ``(setv self.foo foo)``. This is convenient for parameters to ``__init__`` that set attributes of the same name::
+
+    (defclass Rectangle []
+
+      (meth __init__ [@width @height])
+        ; Look Ma, no body!
+
+      (meth area []
+        (* @width @height)))
+
+    (setv x (Rectangle 3 4))
+    (print (.area x))  ; => 12
+
+  The symbol ``@,`` is replaced with just plain ``self``. By contrast, the symbol ``@`` is left untouched, since it may refer to the Hy core macro :hy:func:`@ <hy.pyops.@>`.]]
+
+  (if (and args (isinstance (get args 0) hy.models.List))
+    (setv [decorators name params #* body] args)
+    (setv decorators []  [name params #* body] args))
+  `(defn ~decorators ~name ~@(_meth params body)))
+
+(defmacro ameth [params #* body]
+  "Define an anonymous method. ``ameth`` is to :hy:func:`meth` as :hy:func:`fn` is to :hy:func:`defn`: it has the same syntax except that no method name (or decorators) are allowed."
+  `(fn ~@(_meth params body)))
+
+
+(defn _meth [params body]
+  (setv to-set [])
+  (setv params (map-model params (fn [x]
+    (when (and (isinstance x hy.models.Symbol) (.startswith x "@"))
+      (setv x (hy.models.Symbol (cut x 1 None)))
+      (.append to-set x)
+      x))))
+  (setv body (map-model body (fn [x]
+    (when (and (isinstance x hy.models.Symbol) (.startswith x "@"))
+      (cond
+        (= x '@) '@
+        (= x '@,) 'self
+        True      `(. self ~(hy.models.Symbol (cut x 1 None))))))))
+  `[
+    [self ~@params]
+    ~@(gfor
+      sym to-set
+      `(setv (. self ~sym) ~sym))
+    ~@body])

tests/test_oop.hy

@@ -0,0 +1,109 @@
+(require
+  hyrule [meth ameth])
+(import
+  pytest)
+
+
+(defn example-decorator [f]
+  (setv f.da "hello")
+  f)
+
+
+(defn test-meth []
+
+  (defclass MM []
+    (defn __matmul__ [self other]
+      #("matmul" other)))
+
+  (defclass Pony []
+    (meth set-an-attr [value]
+      "this is a @docstring"
+      (setv @attr value))
+    (meth use-an-attr []
+      (+ @attr 5))
+    (meth at-call []
+      (@set-an-attr 8))
+    (meth get-self []
+      @,)
+    (meth do-matmul []
+      (@ (MM) 2)))
+
+  (setv x (Pony))
+  (assert (= x.set-an-attr.__doc__ "this is a @docstring"))
+  (.set-an-attr x 1)
+  (assert (= x.attr 1))
+  (assert (= (.use-an-attr x) 6))
+  (.at-call x)
+  (assert (= x.attr 8))
+  (assert (is (.get-self x) x))
+  (assert (= (.do-matmul x) #("matmul" 2))))
+
+
+(defn test-meth-decorated []
+
+  (defclass Pony []
+    (meth [classmethod] set-class-attr [value]
+      (setv @attr value))
+    (meth [example-decorator] set-instance-attr [value]
+      (setv @attr value)))
+
+  (assert (= Pony.set-instance-attr.da "hello"))
+  (setv x (Pony))
+  (.set-class-attr x 2)
+  (assert (= x.attr 2))
+  (assert (= Pony.attr 2))
+  (.set-instance-attr x 1)
+  (assert (= x.attr 1))
+  (assert (= Pony.attr 2))
+  (assert (= (. (Pony) attr) 2)))
+
+
+(defn test-meth-init []
+
+  (setv got None)
+
+  (defclass Pony []
+    (meth __init__
+        [a1 @i1 [@i2 "i2-default"] [a2 "a2-default"] #* @ia #** @ikw]
+      (nonlocal got)
+      (setv got [a1 @i1 i2 a2 @ia @ikw])
+      (setv @i1 "override")))
+
+  (setv x (Pony 1 2))
+  (assert (= got [1 2 "i2-default" "a2-default" #() {}]))
+  (assert (= x.i1 "override"))
+  (assert (= x.i2 "i2-default"))
+  (assert (= x.ia #()))
+  (assert (= x.ikw {}))
+  (assert (not (hasattr x "a1")))
+  (assert (not (hasattr x "a2")))
+
+  (setv x (Pony 1 2 3 4 5 6 7 :foo "bar"))
+  (assert (= got [1 2 3 4 #(5 6 7) {"foo" "bar"}]))
+  (assert (= x.i1 "override"))
+  (assert (= x.i2 3))
+  (assert (= x.ia #(5 6 7)))
+  (assert (= x.ikw {"foo" "bar"})))
+
+
+(defn test-meth-init-decorated []
+
+  (defclass Pony []
+    (meth [example-decorator] __init__ [@value]
+      (setv @attr 2)))
+
+  (assert (= Pony.__init__.da "hello"))
+  (setv x (Pony 1))
+  (assert (= x.value 1))
+  (assert (= x.attr 2)))
+
+
+(defn test-ameth []
+
+  (defclass Pony []
+    (setv my-meth (ameth [value]
+      (setv @attr value))))
+
+  (setv x (Pony))
+  (.my-meth x 1)
+  (assert (= x.attr 1)))