Test nested destructuring in dash let form #Emacs

test-nested-destructuring-in-dash-let.el

;;; test-nested-destructuring-in-dash-let.el --- Test nested destructuring in dash let form -*- lexical-binding: t; -*-
;; Author: Gong Qijian <gongqijian@gmail.com>
;; Created: 2020/04/09
;; Version: 1.1
;;; Commentary:
;; Example:
;; ┌────
;; │ (-let [(&alist '(a "b" c) v) '((a . (("b" . ((c . 3))))))] v)
;; │ ;; => (let* ((v (cdr (assoc 'c
;; │ ;;               (cdr (assoc "b"
;; │ ;;                (cdr (assoc 'a
;; │ ;;                 '((a . (("b" . ((c . 3))))))))))))))
;; │ ;;      v)
;; │ ;; => 3
;; └────
;; Discussion: https://github.com/magnars/dash.el/issues/289
;;; Code:


;;; elpa

(setq package-user-dir (concat user-emacs-directory (file-name-base load-file-name) "/elpa/"))

(unless (load "~/.emacs.d/elpa.el" t)
  (setq package-archives
        '(("gnu" . "https://elpa.gnu.org/packages/")
          ("melpa" . "https://melpa.org/packages/"))))

(package-initialize)

(defun require-packages (&rest packages)
  (dolist (pkg packages)
    (unless (package-installed-p pkg)
      (package-refresh-contents)
      (package-install pkg))
    (require pkg)))

(require-packages
 'ht
 'dash)

(require 'cl-macs)
(require 'dash)
(require 'ht)


;;; alist

(defun my/dash-expand:&alist-nested (keys source)
  (if (cdr keys)
      `(cdr (assoc ,(car keys) ,(my/dash-expand:&alist-nested (cdr keys) source)))
    `(cdr (assoc ,(car keys) ,source))))

(defun my/dash-expand:&alist (key source)
  (if (and (consp key) (eq 'quote (car key)) (consp (car (cdr key))))
      (my/dash-expand:&alist-nested
       (mapcar
        (lambda (it)
          (if (symbolp it)
              (list 'quote it)
            it))
        (reverse (car (cdr key))))
       source)
    `(cdr (assoc ,key ,source))))

(progn
  (princ "Test -let &alist ... ")
  (advice-add 'dash-expand:&alist :override #'my/dash-expand:&alist)
  (unwind-protect
      (let* ((actual-sexp1 (macroexpand-all '(-let [(&alist '(a "b" c) v) '((a . (("b" . ((c . 3))))))] v)))
             (actual-sexp2 (macroexpand-all '(-let [(&alist '(a "b")   v) '((a . (("b" . ((c . 3))))))] v)))
             (actual-sexp3 (macroexpand-all '(-let [(&alist 'a         v) '((a . (("b" . ((c . 3))))))] v)))
             (expected-sexp1 '(let* ((v (cdr (assoc 'c (cdr (assoc "b" (cdr (assoc 'a '((a . (("b" . ((c . 3)))))))))))))) v))
             (expected-sexp2 '(let* ((v                (cdr (assoc "b" (cdr (assoc 'a '((a . (("b" . ((c . 3))))))))))))   v))
             (expected-sexp3 '(let* ((v                                (cdr (assoc 'a '((a . (("b" . ((c . 3))))))))))     v))
             (actual-val1 (eval actual-sexp1))
             (actual-val2 (eval actual-sexp2))
             (actual-val3 (eval actual-sexp3))
             (expected-val1  3)
             (expected-val2 '((c . 3)))
             (expected-val3 '(("b" . ((c . 3))))))
        (cl-assert (equal actual-sexp1 expected-sexp1))
        (cl-assert (equal actual-sexp2 expected-sexp2))
        (cl-assert (equal actual-sexp3 expected-sexp3))
        (cl-assert (equal actual-val1 expected-val1))
        (cl-assert (equal actual-val2 expected-val2))
        (cl-assert (equal actual-val3 expected-val3))
        (princ "Pass\n"))
    (advice-remove 'dash-expand:&alist #'my/dash-expand:&alist)))


;;; plist

(defun my/dash-expand:&plist-nested (keys source)
  (if (cdr keys)
      `(plist-get ,(my/dash-expand:&plist-nested (cdr keys) source) ,(car keys))
    `(plist-get ,source ,(car keys))))

(defun my/dash-expand:&plist (key source)
  (if (and (consp key) (eq 'quote (car key)) (consp (car (cdr key))))
      (my/dash-expand:&plist-nested (reverse (car (cdr key))) source)
    `(plist-get ,source ,key)))

(progn
  (princ "Test -let &plist ... ")
  (advice-add 'dash-expand:&plist :override #'my/dash-expand:&plist)
  (unwind-protect
      (let* ((actual-sexp1 (macroexpand-all '(-let [(&plist '(:a :b :c) v) '(:a (:b (:c 3)))] v)))
             (actual-sexp2 (macroexpand-all '(-let [(&plist '(:a :b)    v) '(:a (:b (:c 3)))] v)))
             (actual-sexp3 (macroexpand-all '(-let [(&plist :a          v) '(:a (:b (:c 3)))] v)))
             (expected-sexp1 '(let* ((v (plist-get (plist-get (plist-get '(:a (:b (:c 3))) :a) :b) :c))) v))
             (expected-sexp2 '(let* ((v            (plist-get (plist-get '(:a (:b (:c 3))) :a) :b)))     v))
             (expected-sexp3 '(let* ((v                       (plist-get '(:a (:b (:c 3))) :a)))         v))
             (actual-val1 (eval actual-sexp1))
             (actual-val2 (eval actual-sexp2))
             (actual-val3 (eval actual-sexp3))
             (expected-val1 3)
             (expected-val2 '(:c 3))
             (expected-val3 '(:b (:c 3))))
        (cl-assert (equal actual-sexp1 expected-sexp1))
        (cl-assert (equal actual-sexp2 expected-sexp2))
        (cl-assert (equal actual-sexp3 expected-sexp3))
        (cl-assert (equal actual-val1 expected-val1))
        (cl-assert (equal actual-val2 expected-val2))
        (cl-assert (equal actual-val3 expected-val3))
        (princ "Pass\n"))
    (advice-remove 'dash-expand:&plist #'my/dash-expand:&plist)))


;;; hash

(defun my/dash-expand:&hash-nested (keys source)
  (if (cdr keys)
      `(gethash ,(car keys) ,(my/dash-expand:&hash-nested (cdr keys) source))
    `(gethash ,(car keys) ,source)))

(defun my/dash-expand:&hash (key source)
  (if (and (consp key) (eq 'quote (car key)) (consp (car (cdr key))))
      (my/dash-expand:&hash-nested
       (mapcar
        (lambda (it)
          (if (and (symbolp it) (not (keywordp it)))
              (list 'quote it)
            it))
        (reverse (car (cdr key))))
       source)
    `(gethash ,key ,source)))

(defun my/dash-expand:&hash? (key source)
  "Generate extracting KEY from SOURCE for &hash? destructuring.
Similar to &hash but check whether the map is not nil."
  (let ((src (make-symbol "src")))
    `(let ((,src ,source))
       (when ,src ,(my/dash-expand:&hash key src)))))

(progn
  (princ "Test -let &hash  ... ")
  (advice-add 'dash-expand:&hash :override #'my/dash-expand:&hash)
  (unwind-protect
      (let ((aht (ht<-alist
                  (list
                   (cons
                    'a
                    (ht<-alist
                     (list
                      (cons
                       'b
                       (ht<-alist
                        '((c . 3))))))))))
            (pht (ht<-plist
                  (list
                   :a
                   (ht<-plist
                    (list
                     :b
                     (ht<-plist
                      '(:c 3))))))))
        (cl-assert (equal (-let [(&hash '(a b c)    v) aht] v) 3))
        (cl-assert (equal (-let [(&hash '(:a :b :c) v) pht] v) 3))
        (princ "Pass\n"))
    (advice-remove 'dash-expand:&hash #'my/dash-expand:&hash)))



;; Local Variables:
;; quickrun-option-cmd-alist: ((:command . "/bin/bash")
;;                             (:exec . ("emacs -Q -l %s --batch"))
;;                             (:tempfile . nil))
;; End:

;;; test-nested-destructuring-in-dash-let.el ends here