code.delx.au - gnu-emacs-elpa/blob - validate.el

   1 ;;; validate.el --- Schema validation for Emacs-lisp  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2016  Artur Malabarba
   4
   5 ;; Author: Artur Malabarba <emacs@endlessparentheses.com>
   6 ;; Keywords: lisp
   7 ;; Package-Requires: ((emacs "24.1") (cl-lib "0.5"))
   8 ;; Version: 0.1
   9
  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.
  14
  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.
  19
  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/>.
  22
  23 ;;; Commentary:
  24 ;;
  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:
  29 ;;
  30 ;;   1.  (validate-variable 'cider-known-endpoints)
  31 ;;   2.  cider-known-endpoints
  32 ;;
  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
  36 ;; the line.
  37 ;;
  38 ;; The format and language of the schemas is the same one used in the
  39 ;; `:type' property of a `defcustom'.
  40 ;;
  41 ;;     See: (info "(elisp) Customization Types")
  42 ;;
  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.
  48
  49 ;;; Todo:
  50 ;;
  51 ;; :inline, `plist',`coding-system',`color',`hook',`restricted-sexp'.
  52
  53 ;;; Code:
  54 (require 'cl-lib)
  55 (require 'seq)
  56 (require 'cus-edit)
  57
  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))))
  63
  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))
  69         (props nil))
  70     (while (and (keywordp (car args)) (cdr args))
  71       (setq props `(,(pop args) ,(pop args) ,@props)))
  72     (setq args (or (plist-get props :args)
  73                    args))
  74     (let ((r
  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
  80                ((sexp other) nil)
  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)
  86                              ((wtype 'string))
  87                              (t "not a valid regexp")))
  88                (repeat (cond
  89                         ((or (not args) (cdr args)) (error "`repeat' needs exactly one argument"))
  90                         ((wtype 'list))
  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)
 104                                   (wtype 'vector)))
 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"))
 119                               ((wtype 'list))
 120                               (t (validate--check value
 121                                           `(repeat (cons ,key-type ,value-type)))))))
 122                ;; TODO: `plist'
 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)))
 134                                                 value
 135                                                 failed)))
 136                               (unless (eq elem failed)
 137                                 (setq value (remove elem value)))))
 138                           (when value
 139                             (concat "the following values don't match any of the options:\n  "
 140                                     (mapconcat (lambda (x) (format "%s" x)) value "\n  "))))))))))
 141       (when r
 142         (let ((print-length 4)
 143               (print-level 2))
 144           (format "Looking for `%S' in `%S' failed because:\n%s"
 145                   schema value r))))))
 146
 147 \f
 148 ;;; Exposed API
 149 ;;;###autoload
 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'.
 153
 154 If NOERROR is non-nil, return t to indicate a match and nil to
 155 indicate a failure."
 156   (let ((report (validate--check value schema)))
 157     (if report
 158         (unless noerror
 159           (user-error report))
 160       value)))
 161
 162 ;;;###autoload
 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)))
 170     (if type
 171         (validate-value val type)
 172       (if noerror val
 173         (error "Variable `%s' has no custom-type." symbol)))))
 174
 175 (provide 'validate)
 176 ;;; validate.el ends here