diff --git a/lisp/plist.el b/lisp/plist.el new file mode 100644 index 0000000..cc2a613 --- /dev/null +++ b/lisp/plist.el @@ -0,0 +1,187 @@ +;;; plist.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 utilitity library for parsing plists around with basic +;; structural validation. + +;;; Code: + +(require 'dash) +(require 'cl-lib) +(require 'subr-x) +(require 'ht) + +(defun plist-keys (plist) + (seq-map #'car (seq-partition plist 2))) + +(defun plist-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 plist-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 plist-map-keys (fn plist) + (let ((pairs (ht-map (lambda (k v) + (list (funcall fn k) v)) + (ht-from-plist plist)))) + (apply 'append pairs))) + +(defun plist-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 plist-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 (plist-keys obj)))) + +(defun plist-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 (plist-p p1) t) + (cl-assert (plist-p p2) t) + (catch 'not-equal + (when (equal (length p1) (length p2)) + (dolist (key (plist-keys p1)) + (let ((v1 (plist-get p1 key)) + (v2 (plist-get p2 key))) + (cond + ((equal v1 v2)) + ((and (plist-p v1) (plist-p v2) (plist-equal v1 v2))) + (t + (throw 'not-equal nil))))) + t))) + +(defun plist--pred-name-for-type (type) + (intern (format "%s-p" type))) + +(defmacro plist-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 ,(plist--pred-name-for-type type) (value &optional strict) + (when (listp value) + (let ((required-keys ',required-keys) + (all-keys ',all-keys)) + (let ((keys (plist-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 plist--validator-for-type (type) + (intern (format "%s-assert" type))) + +(defmacro plist-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 ,(plist--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 (plist-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 plist--pred-accessor-name (type keyword) + (intern (format "%s-%s" type (string-remove-prefix ":" (symbol-name keyword))))) + +(defmacro plist-define-getter (type key) + (cl-assert (symbolp type)) + (cl-assert (keywordp key)) + (let ((validator (plist--validator-for-type type))) + `(defun ,(plist--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 plist--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 plist-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 (plist--format-create-fn-arglist required optional)) + (,(plist--validator-for-type type) attrs) + (plist-pick ',(-union required optional) attrs))) + +(cl-defmacro plist-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 + (plist-define-predicate ,type ,required ,keys) + (plist-define-validator ,type ,required ,keys) + (plist-define-create ,type ,required ,optional) + ,@(seq-map (lambda (it) `(plist-define-getter ,type ,it)) + keys)))) + +(provide 'plist) + +;;; plist.el ends here