From: Artur Malabarba Date: Wed, 4 May 2016 15:00:23 +0000 (-0300) Subject: Add 'packages/validate/' from commit '95865f28b0f0b6386b8dcdf2b084f1cd79ffab0d' X-Git-Url: https://code.delx.au/gnu-emacs-elpa/commitdiff_plain/f94daca2487f73330315b06debd2cefe9fce7cae?hp=-c Add 'packages/validate/' from commit '95865f28b0f0b6386b8dcdf2b084f1cd79ffab0d' git-subtree-dir: packages/validate git-subtree-mainline: 76b6d32e155b55a79d23c15f37cc5d6a647e8f83 git-subtree-split: 95865f28b0f0b6386b8dcdf2b084f1cd79ffab0d --- f94daca2487f73330315b06debd2cefe9fce7cae diff --combined packages/validate/validate.el index 000000000,8408b63c3..8408b63c3 mode 000000,100644..100644 --- a/packages/validate/validate.el +++ b/packages/validate/validate.el @@@ -1,0 -1,186 +1,186 @@@ + ;;; validate.el --- Schema validation for Emacs-lisp -*- lexical-binding: t; -*- + + ;; Copyright (C) 2016 Free Software Foundation, Inc. + + ;; Author: Artur Malabarba + ;; Keywords: lisp + ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5")) + ;; Version: 0.2 + + ;;; Commentary: + ;; + ;; This library offers two functions that perform schema validation. + ;; Use this is your Elisp packages to provide very informative error + ;; messages when your users accidentally misconfigure a variable. + ;; For instance, if everything is fine, these do the same thing: + ;; + ;; 1. (validate-variable 'cider-known-endpoints) + ;; 2. cider-known-endpoints + ;; + ;; However, if the user has misconfigured this variable, option + ;; 1. will immediately give them an informative error message, while + ;; option 2. won't say anything and will lead to confusing errors down + ;; the line. + ;; + ;; The format and language of the schemas is the same one used in the + ;; `:type' property of a `defcustom'. + ;; + ;; See: (info "(elisp) Customization Types") + ;; + ;; Both functions throw a `user-error' if the value in question + ;; doesn't match the schema, and return the value itself if it + ;; matches. The function `validate-variable' verifies whether the value of a + ;; custom variable matches its custom-type, while `validate-value' checks an + ;; arbitrary value against an arbitrary schema. + ;; + ;; Missing features: `:inline', `plist', `coding-system', `color', + ;; `hook', `restricted-sexp'. + + ;;; License: + ;; + ;; This file is part of GNU Emacs. + ;; + ;; GNU Emacs 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. + ;; + ;; GNU Emacs 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 GNU Emacs. If not, see . + + ;;; Code: + (require 'cl-lib) + (require 'seq) + (require 'cus-edit) + + (defun validate--check-list-contents (values schemas) + "Check that all VALUES match all SCHEMAS." + (if (not (= (length values) (length schemas))) + "wrong number of elements" + (seq-find #'identity (seq-mapn #'validate--check values schemas)))) + + (defun validate--check (value schema) + "Return nil if VALUE matches SCHEMA. + If they don't match, return an explanation." + (let ((args (cdr-safe schema)) + (expected-type (or (car-safe schema) schema)) + (props nil)) + (while (and (keywordp (car args)) (cdr args)) + (setq props `(,(pop args) ,(pop args) ,@props))) + (setq args (or (plist-get props :args) + args)) + (let ((r + (cl-labels ((wtype ;wrong-type + (tt) (unless (funcall (intern (format "%sp" tt)) value) + (format "not a %s" tt)))) + ;; TODO: hook (top-level only). + (cl-case expected-type + ((sexp other) nil) + (variable (cond ((wtype 'symbol)) + ((not (boundp value)) "this symbol has no variable binding"))) + ((integer number float string character symbol function boolean face) + (wtype expected-type)) + (regexp (cond ((ignore-errors (string-match value "") t) nil) + ((wtype 'string)) + (t "not a valid regexp"))) + (repeat (cond + ((or (not args) (cdr args)) (error "`repeat' needs exactly one argument")) + ((wtype 'list)) + (t (let ((subschema (car args))) + (seq-some (lambda (v) (validate--check v subschema)) value))))) + ((const function-item variable-item) (unless (eq value (car args)) + "not the expected value")) + (file (cond ((wtype 'string)) + ((file-exists-p value) nil) + ((plist-get props :must-match) "file does not exist") + ((not (file-writable-p value)) "file is not accessible"))) + (directory (cond ((wtype 'string)) + ((file-directory-p value) nil) + ((file-exists-p value) "path is not a directory") + ((not (file-writable-p value)) "directory is not accessible"))) + (key-sequence (and (wtype 'string) + (wtype 'vector))) + ;; TODO: `coding-system', `color' + (coding-system (wtype 'symbol)) + (color (wtype 'string)) + (cons (or (wtype 'cons) + (validate--check (car value) (car args)) + (validate--check (cdr value) (cadr args)))) + ((list group) (or (wtype 'list) + (validate--check-list-contents value args))) + (vector (or (wtype 'vector) + (validate--check-list-contents value args))) + (alist (let ((value-type (plist-get props :value-type)) + (key-type (plist-get props :key-type))) + (cond ((not value-type) (error "`alist' needs a :value-type")) + ((not key-type) (error "`alist' needs a :key-type")) + ((wtype 'list)) + (t (validate--check value + `(repeat (cons ,key-type ,value-type))))))) + ;; TODO: `plist' + ((choice radio) (if (not (cdr args)) + (error "`choice' needs at least one argument") + (let ((gather (mapcar (lambda (x) (validate--check value x)) args))) + (when (seq-every-p #'identity gather) + (concat "all of the options failed\n " + (mapconcat #'identity gather "\n ")))))) + ;; TODO: `restricted-sexp' + (set (or (wtype 'list) + (let ((failed (list t))) + (dolist (schema args) + (let ((elem (seq-find (lambda (x) (not (validate--check x schema))) + value + failed))) + (unless (eq elem failed) + (setq value (remove elem value))))) + (when value + (concat "the following values don't match any of the options:\n " + (mapconcat (lambda (x) (format "%s" x)) value "\n ")))))))))) + (when r + (let ((print-length 4) + (print-level 2)) + (format "Looking for `%S' in `%S' failed because:\n%s" + schema value r)))))) + + + ;;; Exposed API + ;;;###autoload + (defun validate-value (value schema &optional noerror) + "Check that VALUE matches SCHEMA. + If it matches return VALUE, otherwise signal a `user-error'. + + If NOERROR is non-nil, return t to indicate a match and nil to + indicate a failure." + (let ((report (validate--check value schema))) + (if report + (unless noerror + (user-error report)) + value))) + + ;;;###autoload + (defun validate-variable (symbol &optional noerror) + "Check that SYMBOL's value matches its schema. + SYMBOL must be the name of a custom option with a defined + `custom-type'. If SYMBOL has a value and a type, they are checked + with `validate-value'. NOERROR is passed to `validate-value'." + (let* ((val (symbol-value symbol)) + (type (custom-variable-type symbol))) + (if type + (validate-value val type) + (if noerror val + (error "Variable `%s' has no custom-type." symbol))))) + + ;;;###autoload + (defun validate-mark-safe-local (symbol) + "Mark SYMBOL as a safe local if its custom type is obeyed." + (put symbol 'safe-local-variable + (lambda (val) + (validate-value val (custom-variable-type symbol) 'noerror)))) + + (provide 'validate) + ;;; validate.el ends here