Merge pull request #85 from Kodiologist/simalq-imports

Add some utility functions and macros from Infinitesimal Quest 2 + ε

NEWS.rst

@@ -1,5 +1,15 @@
 .. default-role:: code
 
+Unreleased
+======================================================
+
+New Features
+------------------------------
+* New macro `defmacro-kwargs`.
+* New macro `parse-fn-params`.
+* New function `sign`.
+* New function `thru`.
+
 0.5.0 (released 2024-01-05; uses Hy 0.28.*)
 ======================================================
 

docs/index.rst

@@ -91,15 +91,19 @@ Reference
 .. hy:autofunction:: drop-last
 .. hy:autofunction:: flatten
 .. hy:autofunction:: rest
+.. hy:autofunction:: thru
 
 ``macrotools`` — Tools for writing and handling macros
 ----------------------------------------------------------------------
 .. hy:automodule:: hyrule.macrotools
 
 .. hy:autotag:: /
+.. hy:automacro:: defmacro-kwargs
 .. hy:automacro:: defmacro/g!
 .. hy:automacro:: defmacro!
 .. hy:autofunction:: macroexpand-all
+.. hy:autofunction:: map-model
+.. hy:autofunction:: match-fn-params
 .. hy:automacro:: with-gensyms
 
 ``pprint`` — Pretty-printing data structures
@@ -133,6 +137,7 @@ Reference
 .. hy:autofunction:: parse-args
 .. hy:automacro:: profile/calls
 .. hy:automacro:: profile/cpu
+.. hy:autofunction:: sign
 .. hy:automacro:: smacrolet
 .. hy:autofunction:: xor
 

hyrule/iterables.hy

@@ -161,3 +161,20 @@
        []
   "
   (islice coll 1 None))
+
+
+(defn thru [a [b None] [step 1]]
+  "A doubly inclusive version of :py:class:`range`. It takes the same
+  arguments as ``range``, but includes the endpoint (given a
+  compatible start point and step size). ::
+
+    (thru 3)
+      ; => [0 1 2 3]
+    (thru 0 10 2)
+      ; => [0 2 4 6 8 10]
+    (thru 0 9 2)
+      ; => [0 2 4 6 8]"
+
+  (when (is b None)
+    (setv [a b] [0 a]))
+  (range a (+ b (if (> step 0) 1 -1)) step))

hyrule/macrotools.hy

@@ -4,6 +4,151 @@
   hyrule.collections [walk])
 
 
+(defmacro defmacro-kwargs [name params #* body]
+
+  #[=[Define a macro that can take keyword arguments. When the macro
+  is called, :hy:func:`match-fn-params` is used to match the
+  arguments against ``params``, and the parameters are assigned to
+  local variables that can be used in the macro body. ::
+
+    (defmacro-kwargs do10times [form [print-iteration 'False]]
+      (setv i (hy.gensym))
+      `(for [~i (range 10)]
+        (when ~print-iteration
+          (print "Now on iteration:" ~i))
+        ~form))
+
+    (setv x [])
+    (do10times
+      (.append x 1))
+    ; Nothing is printed.
+    (do10times
+      :print-iteration (> (len x) 17)
+      (.append x 1))
+    ; Iterations 8 and 9 are printed.]=]
+
+  (setv [ps p-rest p-kwargs] (parse-fn-params params))
+  (setv docstring None)
+  (when (and body (isinstance (get body 0) hy.models.String))
+    (setv [docstring #* body] body))
+  (setv g (hy.gensym))
+  `(defmacro ~name [#* ~g]
+    ~@(if docstring [docstring] [])
+    (setv ~g (hy.I.hyrule.match-fn-params ~g '~params))
+    ~@(gfor
+      k [
+        #* (.keys ps)
+        #* (if p-rest [p-rest] [])
+        #* (if p-kwargs [p-kwargs] [])]
+      `(setv ~(hy.models.Symbol k) (get ~g ~k)))
+    ~@body))
+
+(defn match-fn-params [args params]
+  #[[Match an iterable of arguments against a parameter list in the
+  style of a :hy:func:`defn` lambda list. The parameter-list syntax
+  here is somewhat restricted: annotations are forbiddden, ``/`` and
+  ``*`` aren't recognized, and nothing is allowed after ``#* args``
+  other than ``#** kwargs``. Return a dictionary of the parameters and
+  their values. ::
+
+    (match-fn-params
+      [1 :foo "x"]
+      '[a [b 2] [c 3] #* args #** kwargs])
+    ; => {"a" 1  "b" 2  "c" 3  "args" #()  "kwargs" {"foo" "x"}}
+
+  If a default argument is a :ref:`model <hy:models>`, it's evaluated.
+  The evaluation occurs in a minimal environment, with no access to
+  surrounding global or local Python-level objects or macros. If this
+  is too restrictive, use ``None`` as the default value and compute the
+  real default value in other code.
+
+  This function exists mostly to implement :hy:macro:`defmacro-kwargs`.]]
+
+  (setv [ps p-rest p-kwargs] (parse-fn-params params))
+
+  ; Loop over `args`.
+  (setv  args (list args)  collected-rest []  collected-kwargs {}  i-pos 0)
+  (while args
+    (setv x (.pop args 0))
+    (cond
+
+      (and
+          (isinstance x hy.models.Expression)
+          x
+          (isinstance (get x 0) hy.models.Symbol)
+          (in (hy.mangle (get x 0)) ["unpack_iterable" "unpack_mapping"]))
+        ; Unpacking would require evaluating the elements of `args`, which we
+        ; want to avoid.
+        (raise (TypeError "unpacking is not allowed in `args`"))
+
+      (isinstance x hy.models.Keyword) (do
+        ; A keyword argument
+        (setv x (hy.mangle x.name))
+        (when (or
+            (in x collected-kwargs)
+            (and (in x ps) (is-not (get ps x "value") None)))
+          (raise (TypeError (+ "keyword argument repeated: " x))))
+        (setv v (.pop args 0))
+        (cond
+          (in x ps)
+            (setv (get ps x "value") v)
+          p-kwargs
+            (setv (get collected-kwargs x) v)
+          True
+            (raise (TypeError f"unexpected keyword argument '{x}'"))))
+
+      True (do
+        ; A positional argument
+        (cond
+          (< i-pos (len ps)) (do
+            (setv [k d] (get (list (.items ps)) i-pos))
+            (if (is (get d "value") None)
+              (setv (get d "value") x)
+              (raise (TypeError f"got multiple values for argument '{k}'"))))
+          p-rest
+            (.append collected-rest x)
+          True
+            (raise (TypeError f"takes {(len ps)} positional arguments but more were given")))
+        (+= i-pos 1))))
+
+  ; Return the result.
+  (dict
+    #** (dfor
+      [p d] (.items ps)
+      p (cond
+        (is-not (get d "value") None)
+          (get d "value")
+        (is-not (get d "default") None)
+          (get d "default")
+        True
+          (raise (TypeError f"missing a required positional argument: '{p}'"))))
+    #** (if p-rest {p-rest (tuple collected-rest)} {})
+    #** (if p-kwargs {p-kwargs collected-kwargs} {})))
+
+(defn parse-fn-params [params]
+  "A subroutine for `defmacro-kwargs` and `match-params`."
+  (import
+    funcparserlib.parser [maybe many]
+    hy.model-patterns [SYM FORM sym brackets pexpr])
+
+  (setv msym (>> SYM hy.mangle))
+  (defn pvalue [root wanted]
+    (>> (pexpr (+ (sym root) wanted)) (fn [x] (get x 0))))
+  (setv [ps p-rest p-kwargs] (.parse
+    (+
+      (many (| msym (brackets msym FORM)))
+      (maybe (pvalue "unpack-iterable" msym))
+      (maybe (pvalue "unpack-mapping" msym)))
+    params))
+  (setv ps (dfor
+    p ps
+    :setv [k dv] (if (isinstance p hy.models.List) p [p None])
+    k (dict :value None :default (if (isinstance dv hy.models.Object)
+     (hy.eval dv {} :macros {})
+     dv))))
+  [ps p-rest p-kwargs])
+
+
 (defmacro defmacro/g! [name args #* body]
   "Like `defmacro`, but symbols prefixed with 'g!' are gensymed.
 
@@ -126,6 +271,52 @@
   (expand form))
 
 
+(defn map-model [x f]
+  #[[Recursively apply a callback to some code. The unary function ``f`` is called on the object ``x``, converting it to a :ref:`model <hy:models>` first if it isn't one already. If the return value isn't ``None``, it's converted to a model and used as the result. But if the return value is ``None``, and ``x`` isn't a :ref:`sequential model <hy:hysequence>`, then ``x`` is used as the result instead. ::
+
+     (defn f [x]
+       (when (= x 'b)
+         'B))
+     (map-model 'a f)  ; => 'a
+     (map-model 'b f)  ; => 'B
+
+  Recursive descent occurs when ``f`` returns ``None`` and ``x`` is sequential. Then ``map-model`` is called on all the elements of ``x`` and the results are bound up in the same model type as ``x``. ::
+
+    (map-model '[a [b c] d] f)  ; => '[a [B c] d]
+
+  The typical use of ``map-model`` is to write a macro that replaces models of a selected kind, however deeply they're nested in a tree of models. ::
+
+    (defmacro lowercase-syms [#* body]
+      "Evaluate `body` with all symbols downcased."
+      (hy.I.hyrule.map-model `(do ~@body) (fn [x]
+        (when (isinstance x hy.models.Symbol)
+          (hy.models.Symbol (.lower (str x)))))))
+    (lowercase-syms
+      (SETV FOO 15)
+      (+= FOO (ABS -5)))
+    (print foo)  ; => 20
+
+  That's why the parameters of ``map-model`` are backwards compared to ``map``: in user code, ``x`` is typically a symbol or other simple form whereas ``f`` is a multi-line anonymous function.]]
+
+  (when (not (isinstance x hy.models.Object))
+    (setv x (hy.as-model x)))
+  (cond
+    (is-not (setx value (f x)) None)
+      (hy.as-model value)
+    (isinstance x hy.models.Sequence)
+      ((type x)
+        (gfor  elem x  (map-model elem f))
+        #** (cond
+          (isinstance x hy.models.FString)
+            {"brackets" x.brackets}
+          (isinstance x hy.models.FComponent)
+            {"conversion" x.conversion}
+          True
+            {}))
+    True
+      x))
+
+
 (defmacro with-gensyms [args #* body]
   "Execute `body` with `args` as bracket of names to gensym for use in macros.
 

hyrule/misc.hy

@@ -256,6 +256,26 @@
      (print (.getvalue ~g!hy-s))))
 
 
+(do-mac (do
+  (setv code "
+      (cond
+        (< x 0) -1
+        (> x 0)  1
+        (= x 0)  0
+        True     (raise TypeError))")
+
+  `(defn sign [x]
+    ~f"Return -1 for negative ``x``, 1 for positive ``x``, and 0 for
+    ``x`` equal to 0. The implementation is exactly ::
+
+    {code}
+
+    with the corresponding consequences for special cases like negative
+    zero and NaN."
+
+      ~(hy.read code))))
+
+
 (defn xor [a b]
   "Perform exclusive or between `a` and `b`.
 

tests/test_iterables.hy

@@ -1,6 +1,7 @@
 (import
   itertools [count islice]
-  hyrule [butlast coll? distinct drop-last flatten rest])
+  hyrule [butlast coll? distinct drop-last flatten rest thru]
+  pytest)
 
 
 (defn test-butlast []
@@ -79,3 +80,28 @@
   (assert (= (list (rest [1 2 3 4 5])) [2 3 4 5]))
   (assert (= (list (islice (rest (count 8)) 3)) [9 10 11]))
   (assert (= (list (rest [])) [])))
+
+
+(defn test-thru []
+  (assert (is (type (thru 5)) (type (range 5))))
+
+  (defn check [args values]
+    (assert (= (list (thru #* args)) values)))
+  (check [3]       [0 1 2 3])
+  (check [-1 3]    [-1 0 1 2 3])
+  (check [-1]      [])
+  (check [3 1]     [])
+  (check [3 1 -1]  [3 2 1])
+  (check [0 5 2]   [0 2 4])
+  (check [0 6 2]   [0 2 4 6])
+  (check [5 0 -2]  [5 3 1])
+  (check [6 0 -2]  [6 4 2 0])
+
+  (assert [(pytest.raises TypeError)]
+    (thru))
+  (assert [(pytest.raises TypeError)]
+    (thru 3.0))
+  (assert [(pytest.raises TypeError)]
+    (thru "3"))
+  (assert [(pytest.raises ValueError)]
+    (thru 1 10 0)))