;;; plisty.el --- Utilities for working with plists -*- lexical-binding: t; -*- ;; Copyright (C) 2022 Chris Barrett ;; Package-Requires: ((emacs "27.1") (dash "2.19.1") (ht "2.4")) ;; Author: Chris Barrett ;; Homepage: https://github.com/chrisbarrett/nursery ;; Version: 0.0.1-pre ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; Dinky little utility library for defining simple schemas for plists. ;;; Code: (require 'dash) (require 'cl-lib) (require 'subr-x) (require 'ht) (defun plisty-keys (plist) (seq-map #'car (seq-partition plist 2))) (defun plisty-pick (key-or-keys plist) (let ((keys (flatten-list (list key-or-keys))) (ht (ht-from-plist plist))) (ht-reject! (lambda (key _v) (not (seq-contains-p keys key))) ht) (ht-to-plist ht))) (defun plisty-omit (key-or-keys plist) (let ((keys (flatten-list (list key-or-keys))) (ht (ht-from-plist plist))) (ht-reject! (lambda (key _v) (seq-contains-p keys key)) ht) (ht-to-plist ht))) (defun plisty-map-keys (fn plist) (let ((pairs (ht-map (lambda (k v) (list (funcall fn k) v)) (ht-from-plist plist)))) (apply 'append pairs))) (defun plisty-merge (p1 p2) "Merge two plists, such that keys in P2 override duplicates in P1." (let* ((h1 (ht-from-plist p1)) (h2 (ht-from-plist p2)) (merged (ht-merge h1 h2))) (ht-to-plist merged))) (defun plisty-p (obj) "Return t if OBJ is a list and appears to be a plist with keyword keys." (and (listp obj) (cl-evenp (length obj)) (seq-every-p #'keywordp (plisty-keys obj)))) (defun plisty-equal (p1 p2) "Test whether two plists P1 & P2 are structurally equal. Values are compared using `equal', except directly nested plists, which are compared using `plist-equal' recursively." (cl-assert (plisty-p p1) t) (cl-assert (plisty-p p2) t) (catch 'not-equal (when (equal (length p1) (length p2)) (dolist (key (plisty-keys p1)) (let ((v1 (plist-get p1 key)) (v2 (plist-get p2 key))) (cond ((equal v1 v2)) ((and (plisty-p v1) (plisty-p v2) (plisty-equal v1 v2))) (t (throw 'not-equal nil))))) t))) (defun plisty--pred-name-for-type (type) (intern (format "%s-p" type))) (defmacro plisty-define-predicate (type required-keys all-keys) (cl-assert (symbolp type)) (cl-assert (listp required-keys)) (cl-assert (seq-every-p #'keywordp required-keys)) (cl-assert (seq-every-p #'keywordp all-keys)) `(defun ,(plisty--pred-name-for-type type) (value &optional strict) (when (listp value) (let ((required-keys ',required-keys) (all-keys ',all-keys)) (let ((keys (plisty-keys value))) (and (null (seq-difference required-keys keys)) (seq-every-p (lambda (key) (plist-get value key)) required-keys) (if strict (null (seq-difference keys all-keys)) t))))))) (defun plisty--validator-for-type (type) (intern (format "%s-assert" type))) (defmacro plisty-define-validator (type required-keys all-keys) (cl-assert (symbolp type)) (cl-assert (listp required-keys)) (cl-assert (seq-every-p #'keywordp required-keys)) (cl-assert (seq-every-p #'keywordp all-keys)) `(defsubst ,(plisty--validator-for-type type) (value &optional strict) (cl-assert (listp value) t "Expected a plist" ) (let ((required-keys ',required-keys) (all-keys ',all-keys) (keys (plisty-keys value))) (cl-assert (null (seq-difference required-keys keys)) t "Missing required keys: %s" (seq-difference required-keys keys)) (cl-assert (seq-every-p (lambda (key) (plist-get value key)) required-keys) t "Illegal values for required keys: %s" (seq-filter (lambda (key) (null (plist-get value key))) required-keys)) (when strict (cl-assert (null (seq-difference keys all-keys)) t "Unexpected additional keys: %s" (seq-difference keys all-keys)))))) (defun plisty--pred-accessor-name (type keyword) (intern (format "%s-%s" type (string-remove-prefix ":" (symbol-name keyword))))) (defmacro plisty-define-getter (type key) (cl-assert (symbolp type)) (cl-assert (keywordp key)) (let ((validator (plisty--validator-for-type type))) `(defun ,(plisty--pred-accessor-name type key) (,type) ,(format "Lookup `%s' in a plist of type `%s'." key type) (when (fboundp ',validator) (,validator ,type)) (plist-get ,type ,key)))) (defun plisty--format-create-fn-arglist (required optional) (if (or required optional) (format "\n\n\(fn &key %s)" (string-join (append (seq-map (lambda (it) (upcase (string-remove-prefix ":" (symbol-name it)))) required) (seq-map (lambda (it) (format "[%s]" (upcase (string-remove-prefix ":" (symbol-name it))))) optional)) " ")) "")) (defmacro plisty-define-create (type required optional) (cl-assert (symbolp type)) (cl-assert (listp required)) (cl-assert (listp optional)) `(defun ,(intern (format "%s-create" type)) (&rest attrs) ,(format "Construct a value of type `%s'.%s" type (plisty--format-create-fn-arglist required optional)) (,(plisty--validator-for-type type) attrs) (plisty-pick ',(-union required optional) attrs))) (cl-defmacro plisty-define (type &key required optional) (declare (indent 1)) (cl-assert (symbolp type)) (cl-assert (listp required)) (cl-assert (listp optional)) (cl-assert (null (seq-intersection required optional))) (let ((keys (-union required optional))) `(progn (plisty-define-predicate ,type ,required ,keys) (plisty-define-validator ,type ,required ,keys) (plisty-define-create ,type ,required ,optional) ,@(seq-map (lambda (it) `(plisty-define-getter ,type ,it)) keys)))) (provide 'plisty) ;;; plisty.el ends here