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.
51 ;; :inline, `plist',`coding-system',`color',`hook',`restricted-sexp'.
58 (defun validate--check-list-contents (values schemas)
59 "Check that all VALUES match all SCHEMAS."
60 (if (not (= (length values) (length schemas)))
61 "wrong number of elements"
62 (seq-find #'identity (seq-mapn #'validate--check values schemas))))
64 (defun validate--check (value schema)
65 "Return nil if VALUE matches SCHEMA.
66 If they don't match, return an explanation."
67 (let ((args (cdr-safe schema))
68 (expected-type (or (car-safe schema) schema))
70 (while (and (keywordp (car args)) (cdr args))
71 (setq props `(,(pop args) ,(pop args) ,@props)))
72 (setq args (or (plist-get props :args)
75 (cl-labels ((wtype ;wrong-type
76 (tt) (unless (funcall (intern (format "%sp" tt)) value)
77 (format "not a %s" tt))))
78 ;; TODO: hook (top-level only).
79 (cl-case expected-type
81 (variable (cond ((wtype 'symbol))
82 ((not (boundp value)) "this symbol has no variable binding")))
83 ((integer number float string character symbol function boolean face)
84 (wtype expected-type))
85 (regexp (cond ((ignore-errors (string-match value "") t) nil)
87 (t "not a valid regexp")))
89 ((or (not args) (cdr args)) (error "`repeat' needs exactly one argument"))
91 (t (let ((subschema (car args)))
92 (seq-some (lambda (v) (validate--check v subschema)) value)))))
93 ((const function-item variable-item) (unless (eq value (car args))
94 "not the expected value"))
95 (file (cond ((wtype 'string))
96 ((file-exists-p value) nil)
97 ((plist-get props :must-match) "file does not exist")
98 ((not (file-writable-p value)) "file is not accessible")))
99 (directory (cond ((wtype 'string))
100 ((file-directory-p value) nil)
101 ((file-exists-p value) "path is not a directory")
102 ((not (file-writable-p value)) "directory is not accessible")))
103 (key-sequence (and (wtype 'string)
105 ;; TODO: `coding-system', `color'
106 (coding-system (wtype 'symbol))
107 (color (wtype 'string))
108 (cons (or (wtype 'cons)
109 (validate--check (car value) (car args))
110 (validate--check (cdr value) (cadr args))))
111 ((list group) (or (wtype 'list)
112 (validate--check-list-contents value args)))
113 (vector (or (wtype 'vector)
114 (validate--check-list-contents value args)))
115 (alist (let ((value-type (plist-get props :value-type))
116 (key-type (plist-get props :key-type)))
117 (cond ((not value-type) (error "`alist' needs a :value-type"))
118 ((not key-type) (error "`alist' needs a :key-type"))
120 (t (validate--check value
121 `(repeat (cons ,key-type ,value-type)))))))
123 ((choice radio) (if (not (cdr args))
124 (error "`choice' needs at least one argument")
125 (let ((gather (mapcar (lambda (x) (validate--check value x)) args)))
126 (when (seq-every-p #'identity gather)
127 (concat "all of the options failed\n "
128 (mapconcat #'identity gather "\n "))))))
129 ;; TODO: `restricted-sexp'
130 (set (or (wtype 'list)
131 (let ((failed (list t)))
132 (dolist (schema args)
133 (let ((elem (seq-find (lambda (x) (not (validate--check x schema)))
136 (unless (eq elem failed)
137 (setq value (remove elem value)))))
139 (concat "the following values don't match any of the options:\n "
140 (mapconcat (lambda (x) (format "%s" x)) value "\n "))))))))))
142 (let ((print-length 4)
144 (format "Looking for `%S' in `%S' failed because:\n%s"
150 (defun validate-value (value schema &optional noerror)
151 "Check that VALUE matches SCHEMA.
152 If it matches return VALUE, otherwise signal a `user-error'.
154 If NOERROR is non-nil, return t to indicate a match and nil to
156 (let ((report (validate--check value schema)))
163 (defun validate-variable (symbol &optional noerror)
164 "Check that SYMBOL's value matches its schema.
165 SYMBOL must be the name of a custom option with a defined
166 `custom-type'. If SYMBOL has a value and a type, they are checked
167 with `validate-value'. NOERROR is passed to `validate-value'."
168 (let* ((val (symbol-value symbol))
169 (type (custom-variable-type symbol)))
171 (validate-value val type)
173 (error "Variable `%s' has no custom-type." symbol)))))
176 ;;; validate.el ends here