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
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation, either version 3 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;
  24
  25 ;;; Code:
  26
  27 (defun validate--check-list-contents (values schemas)
  28   "Check that all VALUES match all SCHEMAS."
  29   (if (not (= (length values) (length schemas)))
  30       "wrong number of elements"
  31     (seq-find #'identity (seq-mapn #'validate--check values schemas))))
  32
  33 (defun validate--check (value schema)
  34   "Return nil if VALUE matches SCHEMA.
  35 If they don't match, return an explanation."
  36   (let ((fail (list schema value))
  37         (args (cdr-safe schema))
  38         (expected-type (or (car-safe schema) schema))
  39         (props nil))
  40     (while (and (keywordp (car args)) (cdr args))
  41       (setq props `(,(pop args) ,(pop args) ,@props)))
  42     (setq args (or (plist-get props :args)
  43                    args))
  44     (let ((r
  45            (cl-labels ((wtype ;wrong-type
  46                         (t) (unless (funcall (intern (format "%sp" t)) value)
  47                               (format "not a %s" t))))
  48              ;; TODO: hook (top-level only).
  49              (cl-case expected-type
  50                ((sexp other) nil)
  51                (variable (cond ((wtype 'symbol))
  52                                ((not (boundp value)) "this symbol has no variable binding")))
  53                ((integer number float string character symbol function boolean face)
  54                 (wtype expected-type))
  55                (regexp (cond ((ignore-errors (string-match re "") t) nil)
  56                              ((wtype 'string))
  57                              (t "not a valid regexp")))
  58                (repeat (cond
  59                         ((or (not args) (cdr args)) (error "`repeat' needs exactly one argument"))
  60                         ((wtype 'list))
  61                         (t (let ((subschema (car args)))
  62                              (seq-some (lambda (v) (validate--check v subschema)) value)))))
  63                ((const function-item variable-item) (unless (eq value (car args))
  64                                                       "not the expected value"))
  65                (file (cond ((wtype 'string))
  66                            ((file-exists-p value) nil)
  67                            ((plist-get props :must-match) "file does not exist")
  68                            ((not (file-writable-p value)) "file is not accessible")))
  69                (directory (cond ((wtype 'string))
  70                                 ((file-directory-p value) nil)
  71                                 ((file-exists-p value) "path is not a directory")
  72                                 ((not (file-writable-p value)) "directory is not accessible")))
  73                (key-sequence (and (wtype 'string)
  74                                   (wtype 'vector)))
  75                ;; TODO: `coding-system', `color'
  76                (coding-system (wtype 'symbol))
  77                (color (wtype 'string))
  78                (cons (or (wtype 'cons)
  79                          (validate--check (car value) (car args))
  80                          (validate--check (cdr value) (cadr args))))
  81                ((list group) (or (wtype 'list)
  82                                  (validate--check-list-contents value args)))
  83                (vector (or (wtype 'vector)
  84                            (validate--check-list-contents value args)))
  85                (alist (let ((value-type (plist-get props :value-type))
  86                             (key-type (plist-get props :key-type)))
  87                         (cond ((not value-type) (error "`alist' needs a :value-type"))
  88                               ((not key-type) (error "`alist' needs a :key-type"))
  89                               ((wtype 'list))
  90                               (t (validate--check value
  91                                           `(repeat (cons ,key-type ,value-type)))))))
  92                ;; TODO: `plist'
  93                ((choice radio) (if (not (cdr choice))
  94                                    (error "`choice' needs at least one argument")
  95                                  (let ((gather (mapcar (lambda (x) (validate--check value x)) args)))
  96                                    (when (seq-every-p #'identity gather)
  97                                      (concat "all of the options failed\n  "
  98                                              (mapconcat #'identity gather "\n  "))))))
  99                ;; TODO: `restricted-sexp'
 100                (set (or (wtype 'list)
 101                         (let ((failed (list t)))
 102                           (dolist (schema args)
 103                             (let ((elem (seq-find (lambda (x) (not (validate--check x schema)))
 104                                                 value
 105                                                 failed)))
 106                               (unless (eq elem failed)
 107                                 (setq value (remove elem value)))))
 108                           (when value
 109                             (concat "the following values don't match any of the options:\n  "
 110                                     (mapconcat (lambda (x) (format "%s" x)) value "\n  "))))))))))
 111       (when r
 112         (let ((print-length 4)
 113               (print-level 2))
 114           (format "Looking for `%S' in `%S' failed because:\n%s"
 115                   schema value r))))))
 116
 117 \f
 118 ;;; Exposed API
 119 ;;;###autoload
 120 (defun validate-value (value schema &optional noerror)
 121   "Check that VALUE matches SCHEMA.
 122 If it matches return VALUE, otherwise signal a `user-error'.
 123
 124 If NOERROR is non-nil, return t to indicate a match and nil to
 125 indicate a failure."
 126   (let ((report (validate--check value schema)))
 127     (if report
 128         (unless noerror
 129           (user-error report))
 130       value)))
 131
 132 ;;;###autoload
 133 (defun validate-variable (symbol &optional noerror)
 134   "Check that SYMBOL's value matches its schema.
 135 SYMBOL must be the name of a custom option with a defined
 136 `custom-type'. If SYMBOL has a value and a type, they are checked
 137 with `validate-value'. NOERROR is passed to `validate-value'."
 138   (let* ((val (symbol-value symbol))
 139          (type (custom-variable-type symbol)))
 140     (if type
 141         (validate-value val type)
 142       (if noerror val
 143         (error "Variable `%s' has no custom-type." symbol)))))
 144
 145 (provide 'validate)
 146 ;;; validate.el ends here