Don't try to validate undefined vars
[gnu-emacs-elpa] / validate.el
1 ;;; validate.el --- Schema validation for Emacs-lisp -*- lexical-binding: t; -*-
2
3 ;; Copyright (C) 2016 Free Software Foundation, Inc.
4
5 ;; Author: Artur Malabarba <emacs@endlessparentheses.com>
6 ;; Keywords: lisp
7 ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
8 ;; Version: 0.4
9
10 ;;; Commentary:
11 ;;
12 ;; This library offers two functions that perform schema validation.
13 ;; Use this is your Elisp packages to provide very informative error
14 ;; messages when your users accidentally misconfigure a variable.
15 ;; For instance, if everything is fine, these do the same thing:
16 ;;
17 ;; 1. (validate-variable 'cider-known-endpoints)
18 ;; 2. cider-known-endpoints
19 ;;
20 ;; However, if the user has misconfigured this variable, option
21 ;; 1. will immediately give them an informative error message, while
22 ;; option 2. won't say anything and will lead to confusing errors down
23 ;; the line.
24 ;;
25 ;; The format and language of the schemas is the same one used in the
26 ;; `:type' property of a `defcustom'.
27 ;;
28 ;; See: (info "(elisp) Customization Types")
29 ;;
30 ;; Both functions throw a `user-error' if the value in question
31 ;; doesn't match the schema, and return the value itself if it
32 ;; matches. The function `validate-variable' verifies whether the value of a
33 ;; custom variable matches its custom-type, while `validate-value' checks an
34 ;; arbitrary value against an arbitrary schema.
35 ;;
36 ;; Missing features: `:inline', `plist', `coding-system', `color',
37 ;; `hook', `restricted-sexp'.
38
39 ;;; License:
40 ;;
41 ;; This file is part of GNU Emacs.
42 ;;
43 ;; GNU Emacs is free software: you can redistribute it and/or modify
44 ;; it under the terms of the GNU General Public License as published by
45 ;; the Free Software Foundation, either version 3 of the License, or
46 ;; (at your option) any later version.
47 ;;
48 ;; GNU Emacs is distributed in the hope that it will be useful,
49 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
50 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
51 ;; GNU General Public License for more details.
52 ;;
53 ;; You should have received a copy of the GNU General Public License
54 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
55
56 ;;; Code:
57 (require 'cl-lib)
58 (require 'seq)
59 (require 'cus-edit)
60
61 (defun validate--check-list-contents (values schemas)
62 "Check that all VALUES match all SCHEMAS."
63 (if (not (= (length values) (length schemas)))
64 "wrong number of elements"
65 (seq-find #'identity (seq-mapn #'validate--check values schemas))))
66
67 (defun validate--indent-by-2 (x)
68 (replace-regexp-in-string "^" " " x))
69
70 (defun validate--check (value schema)
71 "Return nil if VALUE matches SCHEMA.
72 If they don't match, return an explanation."
73 (let ((args (cdr-safe schema))
74 (expected-type (or (car-safe schema) schema))
75 (props nil))
76 (while (and (keywordp (car args)) (cdr args))
77 (setq props `(,(pop args) ,(pop args) ,@props)))
78 (setq args (or (plist-get props :args)
79 args))
80 (let ((r
81 (cl-labels ((wtype ;wrong-type
82 (tt) (unless (funcall (intern (format "%sp" tt)) value)
83 (format "not a %s" tt))))
84 ;; TODO: hook (top-level only).
85 (cl-case expected-type
86 ((sexp other) nil)
87 (variable (cond ((wtype 'symbol))
88 ((not (boundp value)) "this symbol has no variable binding")))
89 ((integer number float string character symbol function boolean face)
90 (wtype expected-type))
91 (regexp (cond ((ignore-errors (string-match value "") t) nil)
92 ((wtype 'string))
93 (t "not a valid regexp")))
94 (repeat (cond
95 ((or (not args) (cdr args)) (error "`repeat' needs exactly one argument"))
96 ((wtype 'list))
97 (t (let ((subschema (car args)))
98 (seq-some (lambda (v) (validate--check v subschema)) value)))))
99 ((const function-item variable-item) (unless (eq value (car args))
100 "not the expected value"))
101 (file (cond ((wtype 'string))
102 ((file-exists-p value) nil)
103 ((plist-get props :must-match) "file does not exist")
104 ((not (file-writable-p value)) "file is not accessible")))
105 (directory (cond ((wtype 'string))
106 ((file-directory-p value) nil)
107 ((file-exists-p value) "path is not a directory")
108 ((not (file-writable-p value)) "directory is not accessible")))
109 (key-sequence (and (wtype 'string)
110 (wtype 'vector)))
111 ;; TODO: `coding-system', `color'
112 (coding-system (wtype 'symbol))
113 (color (wtype 'string))
114 (cons (or (wtype 'cons)
115 (validate--check (car value) (car args))
116 (validate--check (cdr value) (cadr args))))
117 ((list group) (or (wtype 'list)
118 (validate--check-list-contents value args)))
119 (vector (or (wtype 'vector)
120 (validate--check-list-contents value args)))
121 (alist (let ((value-type (plist-get props :value-type))
122 (key-type (plist-get props :key-type)))
123 (cond ((not value-type) (error "`alist' needs a :value-type"))
124 ((not key-type) (error "`alist' needs a :key-type"))
125 ((wtype 'list))
126 (t (validate--check value
127 `(repeat (cons ,key-type ,value-type)))))))
128 ;; TODO: `plist'
129 ((choice radio) (if (not (cdr args))
130 (error "`choice' needs at least one argument")
131 (let ((gather (mapcar (lambda (x) (validate--check value x)) args)))
132 (when (seq-every-p #'identity gather)
133 (concat "all of the options failed\n"
134 (mapconcat #'validate--indent-by-2 gather "\n"))))))
135 ;; TODO: `restricted-sexp'
136 (set (or (wtype 'list)
137 (let ((failed (list t)))
138 (dolist (schema args)
139 (let ((elem (seq-find (lambda (x) (not (validate--check x schema)))
140 value
141 failed)))
142 (unless (eq elem failed)
143 (setq value (remove elem value)))))
144 (when value
145 (concat "the following values don't match any of the options:\n "
146 (mapconcat (lambda (x) (format "%s" x)) value "\n "))))))))))
147 (when r
148 (let ((print-length 4)
149 (print-level 2))
150 (format "Looking for `%S' in `%S' failed because:\n%s"
151 schema value
152 (if (string-match "\\`Looking" r)
153 r
154 (validate--indent-by-2 r))))))))
155
156 \f
157 ;;; Exposed API
158 ;;;###autoload
159 (defun validate-value (value schema &optional noerror)
160 "Check that VALUE matches SCHEMA.
161 If it matches return VALUE, otherwise signal a `user-error'.
162
163 If NOERROR is non-nil, return t to indicate a match and nil to
164 indicate a failure."
165 (let ((report (validate--check value schema)))
166 (if report
167 (unless noerror
168 (user-error report))
169 value)))
170
171 ;;;###autoload
172 (defun validate-variable (symbol &optional noerror)
173 "Check that SYMBOL's value matches its schema.
174 SYMBOL must be the name of a custom option with a defined
175 `custom-type'. If SYMBOL has a value and a type, they are checked
176 with `validate-value'. NOERROR is passed to `validate-value'."
177 (let* ((val (symbol-value symbol))
178 (type (custom-variable-type symbol)))
179 (if type
180 (validate-value val type)
181 (if noerror val
182 (error "Variable `%s' has no custom-type." symbol)))))
183
184 ;;;###autoload
185 (defun validate-mark-safe-local (symbol)
186 "Mark SYMBOL as a safe local if its custom type is obeyed."
187 (put symbol 'safe-local-variable
188 (lambda (val)
189 (validate-value val (custom-variable-type symbol) 'noerror))))
190
191 (defmacro validate-setq (symbol value)
192 "Like `setq', but throw an error if validation fails.
193 VALUE is validated against SYMBOL's custom type."
194 `(if (boundp ',symbol)
195 (setq ,symbol (validate-value ,value (custom-variable-type ',symbol)))
196 (user-error "Trying to validate a variable that's not defined yet: `%s'.\nYou need to require the package before validating"
197 ',symbol)))
198
199 (provide 'validate)
200 ;;; validate.el ends here