1 ;;; validate.el --- Schema validation for Emacs-lisp -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2016 Artur Malabarba
5 ;; Author: Artur Malabarba <emacs@endlessparentheses.com>
7 ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
25 ;; This library offers two functions that perform schema validation.
26 ;; Use this is your Elisp packages to provide very informative error
27 ;; messages when your users accidentally misconfigure a variable.
28 ;; For instance, if everything is fine, these do the same thing:
30 ;; 1. (validate-variable 'cider-known-endpoints)
31 ;; 2. cider-known-endpoints
33 ;; However, if the user has misconfigured this variable, option
34 ;; 1. will immediately give them an informative error message, while
35 ;; option 2. won't say anything and will lead to confusing errors down
38 ;; The format and language of the schemas is the same one used in the
39 ;; `:type' property of a `defcustom'.
41 ;; See: (info "(elisp) Customization Types")
43 ;; Both functions throw a `user-error' if the value in question
44 ;; doesn't match the schema, and return the value itself if it
45 ;; matches. The function `validate-variable' verifies whether the value of a
46 ;; custom variable matches its custom-type, while `validate-value' checks an
47 ;; arbitrary value against an arbitrary schema.
54 (defun validate--check-list-contents (values schemas)
55 "Check that all VALUES match all SCHEMAS."
56 (if (not (= (length values) (length schemas)))
57 "wrong number of elements"
58 (seq-find #'identity (seq-mapn #'validate--check values schemas))))
60 (defun validate--check (value schema)
61 "Return nil if VALUE matches SCHEMA.
62 If they don't match, return an explanation."
63 (let ((args (cdr-safe schema))
64 (expected-type (or (car-safe schema) schema))
66 (while (and (keywordp (car args)) (cdr args))
67 (setq props `(,(pop args) ,(pop args) ,@props)))
68 (setq args (or (plist-get props :args)
71 (cl-labels ((wtype ;wrong-type
72 (tt) (unless (funcall (intern (format "%sp" tt)) value)
73 (format "not a %s" tt))))
74 ;; TODO: hook (top-level only).
75 (cl-case expected-type
77 (variable (cond ((wtype 'symbol))
78 ((not (boundp value)) "this symbol has no variable binding")))
79 ((integer number float string character symbol function boolean face)
80 (wtype expected-type))
81 (regexp (cond ((ignore-errors (string-match value "") t) nil)
83 (t "not a valid regexp")))
85 ((or (not args) (cdr args)) (error "`repeat' needs exactly one argument"))
87 (t (let ((subschema (car args)))
88 (seq-some (lambda (v) (validate--check v subschema)) value)))))
89 ((const function-item variable-item) (unless (eq value (car args))
90 "not the expected value"))
91 (file (cond ((wtype 'string))
92 ((file-exists-p value) nil)
93 ((plist-get props :must-match) "file does not exist")
94 ((not (file-writable-p value)) "file is not accessible")))
95 (directory (cond ((wtype 'string))
96 ((file-directory-p value) nil)
97 ((file-exists-p value) "path is not a directory")
98 ((not (file-writable-p value)) "directory is not accessible")))
99 (key-sequence (and (wtype 'string)
101 ;; TODO: `coding-system', `color'
102 (coding-system (wtype 'symbol))
103 (color (wtype 'string))
104 (cons (or (wtype 'cons)
105 (validate--check (car value) (car args))
106 (validate--check (cdr value) (cadr args))))
107 ((list group) (or (wtype 'list)
108 (validate--check-list-contents value args)))
109 (vector (or (wtype 'vector)
110 (validate--check-list-contents value args)))
111 (alist (let ((value-type (plist-get props :value-type))
112 (key-type (plist-get props :key-type)))
113 (cond ((not value-type) (error "`alist' needs a :value-type"))
114 ((not key-type) (error "`alist' needs a :key-type"))
116 (t (validate--check value
117 `(repeat (cons ,key-type ,value-type)))))))
119 ((choice radio) (if (not (cdr args))
120 (error "`choice' needs at least one argument")
121 (let ((gather (mapcar (lambda (x) (validate--check value x)) args)))
122 (when (seq-every-p #'identity gather)
123 (concat "all of the options failed\n "
124 (mapconcat #'identity gather "\n "))))))
125 ;; TODO: `restricted-sexp'
126 (set (or (wtype 'list)
127 (let ((failed (list t)))
128 (dolist (schema args)
129 (let ((elem (seq-find (lambda (x) (not (validate--check x schema)))
132 (unless (eq elem failed)
133 (setq value (remove elem value)))))
135 (concat "the following values don't match any of the options:\n "
136 (mapconcat (lambda (x) (format "%s" x)) value "\n "))))))))))
138 (let ((print-length 4)
140 (format "Looking for `%S' in `%S' failed because:\n%s"
146 (defun validate-value (value schema &optional noerror)
147 "Check that VALUE matches SCHEMA.
148 If it matches return VALUE, otherwise signal a `user-error'.
150 If NOERROR is non-nil, return t to indicate a match and nil to
152 (let ((report (validate--check value schema)))
159 (defun validate-variable (symbol &optional noerror)
160 "Check that SYMBOL's value matches its schema.
161 SYMBOL must be the name of a custom option with a defined
162 `custom-type'. If SYMBOL has a value and a type, they are checked
163 with `validate-value'. NOERROR is passed to `validate-value'."
164 (let* ((val (symbol-value symbol))
165 (type (custom-variable-type symbol)))
167 (validate-value val type)
169 (error "Variable `%s' has no custom-type." symbol)))))
172 ;;; validate.el ends here