Klimi's new dotfiles with stow.
25개 이상의 토픽을 선택하실 수 없습니다. Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

252 lines
10 KiB

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