test.lisp - patch - karik/kursach

test.lisp
147 строк4 KB
karik
upload files
06 фев 2026, 18:40
06 фев 2026, 18:40906c845
;;;; ===== Errors =====

(define-condition config-error (error)
  ((module
    :initarg :module
    :reader config-error-module)
   (parameter
    :initarg :parameter
    :reader config-error-parameter)
   (reason
    :initarg :reason
    :reader config-error-reason)
   (value
    :initarg :value
    :initform nil
    :reader config-error-value)
   (expected
    :initarg :expected
    :initform nil
    :reader config-error-expected))
  (:report
   (lambda (c s)
     (format s "~%Ошибка конфигурации:~%")
     (when (config-error-module c)
       (format s "  Модуль: ~a~%" (config-error-module c)))
     (when (config-error-parameter c)
       (format s "  Параметр: ~a~%" (config-error-parameter c)))
     (format s "  Причина: ~a~%" (config-error-reason c))
     (when (config-error-value c)
       (format s "  Получено: ~s~%" (config-error-value c)))
     (when (config-error-expected c)
       (format s "  Ожидалось: ~a~%" (config-error-expected c))))))


(defun signal-config-error (&key module parameter reason value expected)
  (error 'config-error
         :module module
         :parameter parameter
         :reason reason
         :value value
         :expected expected))


;;;; ===== Model =====

(defstruct parameter
  name
  type
  default
  required)

(defstruct config-module
  name
  parameters)


;;;; ===== Registry =====

(defparameter *module-registry* (make-hash-table))

(defun register-module (module)
  (setf (gethash (config-module-name module) *module-registry*) module))

(defun find-module (name)
  (gethash name *module-registry*))


;;;; ===== DSL =====

(defmacro defconfig-module (name &body parameter-specs)
  `(register-module
    (make-config-module
     :name ',name
     :parameters
     (list
      ,@(mapcar
         (lambda (spec)
           (destructuring-bind (param-name &rest options) spec
             `(make-parameter
               :name ,param-name
               :type ',(getf options :type)
               :default ,(getf options :default)
               :required ,(getf options :required nil))))
         parameter-specs)))))


;;;; ===== Validation =====

(defun resolve-parameter-value (module parameter config-alist)
  (let ((entry (assoc (parameter-name parameter) config-alist)))
    (cond
      (entry
       (cdr entry))
      ((parameter-required parameter)
       (signal-config-error
        :module (config-module-name module)
        :parameter (parameter-name parameter)
        :reason "обязательный параметр отсутствует"))
      (t
       (parameter-default parameter)))))

(defun validate-parameter (module parameter value)
  (when (and value
             (parameter-type parameter)
             (not (typep value (parameter-type parameter))))
    (signal-config-error
     :module (config-module-name module)
     :parameter (parameter-name parameter)
     :reason "значение не соответствует ожидаемому типу"
     :value value
     :expected (parameter-type parameter))))

(defun validate-extra-keys (module config-alist)
  (let ((known (mapcar #'parameter-name
                       (config-module-parameters module))))
    (dolist (entry config-alist)
      (unless (member (car entry) known)
        (signal-config-error
         :module (config-module-name module)
         :parameter (car entry)
         :reason "неизвестный параметр")))))


;;;; ===== Build =====

(defun build-module-config (module config-alist)
  (validate-extra-keys module config-alist)
  (mapcar
   (lambda (parameter)
     (let ((value (resolve-parameter-value module parameter config-alist)))
       (validate-parameter module parameter value)
       (cons (parameter-name parameter) value)))
   (config-module-parameters module)))

(defun build-config (input-config)
  (mapcar
   (lambda (entry)
     (let* ((module-name (car entry))
            (config-alist (cdr entry))
            (module (find-module module-name)))
       (unless module
         (signal-config-error
          :module module-name
          :reason "неизвестный модуль"))
       (cons module-name
             (build-module-config module config-alist))))
   input-config))