Add `-defun'

dash.el

@@ -2136,6 +2136,139 @@ because we need to support improper list binding."
       `(let ,inputs
          (-let* ,new-varlist ,@body)))))
 
+(defconst dash--arglist-keywords '(&optional &rest)
+  "List of special symbols in function argument lists.
+These symbols, if encountered, aren't bound to variables, but
+instead have some special effect on the following arguments (e.g.
+make them optional).")
+
+(defun dash--arglist-as-symbolp (matcher)
+  "Check MATCHER is an &as binding with a variable."
+  (cond ((vectorp matcher) (and (>= (length matcher) 2)
+                                (symbolp (aref matcher 0))
+                                (eq '&as (aref matcher 1))))
+        ((listp matcher) (and (symbolp (car matcher))
+                              (listp (cdr matcher))
+                              (eq '&as (cadr matcher))))))
+
+(defun dash--as-matcher-variable (matcher)
+  "Get the variable from &as matcher MATCHER.
+See `dash--arglist-as-symbolp'."
+  (elt matcher 0))
+
+(defun dash--as-matcher-tail (matcher)
+  "Extract the body of a &as-matcher MATCHER.
+\(sym &as ...) => ...."
+  (cond ((vectorp matcher) (dash--vector-tail matcher 2))
+        (t (cddr matcher))))
+
+(defun dash--make-arglist (args)
+  "Make ARGS a function arglist for `dash--destructure-body'."
+  (--map-indexed
+   ;; Don't destructure symbols to themselves
+   (cond ((symbolp it)
+          ;; don't increment the input<n> number for &optional and &rest.
+          (progn (when (memq it dash--arglist-keywords)
+                   (setq it-index (1- it-index))) it))
+         ((dash--arglist-as-symbolp it) (dash--as-matcher-variable it))
+         (t (intern (format "input%d" it-index))))
+   args))
+
+(defun dash--decompose-defun-body (body)
+  "Destructure a `defun' or `lambda' BODY.
+Return a list (DOCSTRING? DECLS REALBODY)."
+  (let* ((docstring? (car body))
+         (docstring? (when (stringp docstring?) docstring?))
+         (result (--split-with (memq (car-safe it) '(declare interactive))
+                               (if docstring? (cdr body) body))))
+    (cons docstring? result)))
+
+(defun dash--docstring-add-signature (docstring arglist)
+  "Add an ARGLIST signature to DOCSTRING.
+If DOCSTRING already has a signature line, do nothing and return
+it. If DOCSTRING is nil, make a docstring that only provides a
+signature line."
+  (if (and docstring (string-match-p "\n\n(fn .*)\\'" docstring))
+      docstring
+    (format "%s\n\n%S" (or docstring "") (cons 'fn arglist))))
+
+(defun dash--destructure-body (arglist body-forms &optional nodoc)
+  "Destructure function ARGLIST using `-let'.
+The result is a list of body forms (including optional docstring
+and declarations) that does the destructuring and executes
+BODY-FORMS. If NODOC is non-nil, omit generating a signature
+docstring if none is provided."
+  (let* ((body-structure (dash--decompose-defun-body body-forms))
+         (docstring? (nth 0 body-structure))
+         (decls (nth 1 body-structure))
+         (body (nth 2 body-structure))
+         (let-bindings
+          (-remove #'null
+                   (--map-indexed
+                    ;; Symbols shouldn't be rebound; they can be taken from the
+                    ;; surrounding environment directly.
+                    (cond ((symbolp it)
+                           (when (memq it dash--arglist-keywords)
+                             (setq it-index (1- it-index))
+                             ;; Don't add a binding for IT-INDEX
+                             nil))
+                          ((dash--arglist-as-symbolp it)
+                           (list (dash--as-matcher-tail it)
+                                 (dash--as-matcher-variable it)))
+                          (t (list it (intern (format "input%d" it-index)))))
+                    arglist))))
+    (nconc
+     ;; If there is no docstring, provide it only if NODOC is not specified.
+     (when (and (or docstring? (not nodoc)))
+       ;; There is no need to add a signature to the doc if only symbols are in
+       ;; the ARGLIST, since support for that is built-in; we want to have no
+       ;; overhead in that case.
+       (list (if (-all? #'symbolp arglist) docstring?
+               (dash--docstring-add-signature docstring? arglist))))
+     decls
+     (if let-bindings
+         `((-let ,let-bindings ,@body))
+       body))))
+
+(defun dash--normalize-arglist (arglist)
+  "Make ARGLIST have the form (MATCHERS...).
+If it is a vector, convert it to a single-matcher arglist."
+  (if (vectorp arglist) (list (append arglist nil)) arglist))
+
+;; TODO: a proper `dash-lambda-list'
+(def-edebug-spec dash-lambda-list sexp)
+
+(defmacro -defun (name match-form &rest body)
+  "Like `-lambda', but as a `defun'.
+Define a function called NAME with destructuring.
+
+MATCH-FORM is like in `-lambda'. Except for the (optional)
+additional destructuring, this function behaves exactly like
+`defun' (in terms of `declare', ...).
+
+\(fn NAME MATCH-FORM &optional DOCSTRING DECL &rest BODY)"
+  (declare (doc-string 3) (indent 2)
+           (debug (&define name dash-lambda-list lambda-doc
+                           [&optional ("declare" &rest sexp)]
+                           [&optional ("interactive" interactive)]
+                           body)))
+  (let ((match-form (dash--normalize-arglist match-form)))
+    `(defun ,name ,(dash--make-arglist match-form)
+       ,@(dash--destructure-body match-form body))))
+
+(defmacro -defmacro (name match-form &rest body)
+  "Like `-defun', but define macro called NAME instead.
+MATCH-FORM and BODY are the same.
+
+\(fn NAME MATCH-FORM &optional DOCSTRING DECL &rest BODY)"
+  (declare (doc-string 3) (indent 2)
+           (debug (&define name dash-lambda-list lambda-doc
+                           [&optional ("declare" &rest sexp)]
+                           body)))
+  (let ((match-form (dash--normalize-arglist match-form)))
+    `(defmacro ,name ,(dash--make-arglist match-form)
+       ,@(dash--destructure-body match-form body))))
+
 (defmacro -lambda (match-form &rest body)
   "Return a lambda which destructures its input as MATCH-FORM and executes BODY.
 
@@ -2145,29 +2278,23 @@ such that:
   (-lambda (x) body)
   (-lambda (x y ...) body)
 
-has the usual semantics of `lambda'.  Furthermore, these get
-translated into normal lambda, so there is no performance
-penalty.
+has the usual semantics of `lambda'. Furthermore, these get
+translated into a normal `lambda', so there is no performance
+penalty. MATCH-FORM may also be a vector, in which case the
+entire vector destructures a single argument:
+
+  (-lambda [a b]) = (-lambda ((a b)))
 
-See `-let' for the description of destructuring mechanism."
+See `-let' for the description of destructuring mechanism.
+
+\(fn MATCH-FORM [DOCSTRING] [INTERACTIVE] BODY)"
   (declare (doc-string 2) (indent defun)
-           (debug (&define sexp
-                           [&optional stringp]
+           (debug (&define dash-lambda-list lambda-doc
                            [&optional ("interactive" interactive)]
                            def-body)))
-  (cond
-   ((not (consp match-form))
-    (signal 'wrong-type-argument "match-form must be a list"))
-   ;; no destructuring, so just return regular lambda to make things faster
-   ((-all? 'symbolp match-form)
-    `(lambda ,match-form ,@body))
-   (t
-    (let* ((inputs (--map-indexed (list it (make-symbol (format "input%d" it-index))) match-form)))
-      ;; TODO: because inputs to the lambda are evaluated only once,
-      ;; -let* need not to create the extra bindings to ensure that.
-      ;; We should find a way to optimize that.  Not critical however.
-      `(lambda ,(--map (cadr it) inputs)
-         (-let* ,inputs ,@body))))))
+  (let ((match-form (dash--normalize-arglist match-form)))
+    `(lambda ,(dash--make-arglist match-form)
+       ,@(dash--destructure-body match-form body t))))
 
 (defmacro -setq (&rest forms)
   "Bind each MATCH-FORM to the value of its VAL.

dev/examples.el

@@ -1166,7 +1166,7 @@ new list."
     (-let (a b) (list a b)) => '(nil nil)
     (-let ((a) (b)) (list a b)) => '(nil nil)
     ;; auto-derived match forms for kv destructuring
-    ;;; test that we normalize all the supported kv stores
+;;; test that we normalize all the supported kv stores
     (-let (((&plist :foo :bar) (list :foo 1 :bar 2))) (list foo bar)) => '(1 2)
     (-let (((&alist :foo :bar) (list (cons :foo 1) (cons :bar 2)))) (list foo bar)) => '(1 2)
     (let ((hash (make-hash-table)))
@@ -1181,7 +1181,7 @@ new list."
       (-let (((&hash? 'a) (funcall fn ht)))
         a)) => '(3)
     (-let (((_ &keys :foo :bar) (list 'ignored :foo 1 :bar 2))) (list foo bar)) => '(1 2)
-    ;;; go over all the variations of match-form derivation
+;;; go over all the variations of match-form derivation
     (-let (((&plist :foo foo :bar) (list :foo 1 :bar 2))) (list foo bar)) => '(1 2)
     (-let (((&plist :foo foo :bar bar) (list :foo 1 :bar 2))) (list foo bar)) => '(1 2)
     (-let (((&plist :foo x :bar y) (list :foo 1 :bar 2))) (list x y)) => '(1 2)
@@ -1259,6 +1259,30 @@ new list."
     (funcall (-lambda (a b) (+ a b)) 1 2) => 3
     (funcall (-lambda (a (b c)) (+ a b c)) 1 (list 2 3)) => 6)
 
+  (defexamples -defun
+    (progn (-defun example/cdr ((_ . tail)) tail)
+           (example/cdr '(a . b))) => 'b
+    (progn (-defun example/car ((cur)) cur)
+           (example/car '(a . b))) => 'a
+    (progn (-defun example/add-cons ((a . b))
+             "Add the `car' and `cdr' of INPUT0."
+             (interactive (list (cons 1 2)))
+             (+ a b))
+           (command-execute #'example/add-cons)) => 3
+    (progn (-defun example/add-conses-rec (&rest (cur . other))
+             (if other
+                 (+ (example/add-cons cur)
+                    (apply #'example/add-conses-rec other))
+               (example/add-cons cur)))
+           (example/add-conses-rec '(1 . 5) '(5 . 10))) => 21)
+
+  (defexamples -defmacro
+    (progn (-defmacro example/ht-query ((_query &as &plist :key) table)
+             `(gethash ,key ,table))
+           (example/ht-query (:key 'k) (--doto (make-hash-table)
+                                         (puthash 'k "v" it))))
+    => "v")
+
   (defexamples -setq
     (progn (-setq a 1) a) => 1
     (progn (-setq (a b) (list 1 2)) (list a b)) => '(1 2)