Guile 2.2 validation helpers

validation.scm

;; test helper

(define-syntax test-check
  (syntax-rules ()
    ((_ title tested-expression expected-result)
     (when (getenv "TEST")
       (format #t "** Checking ~a\n" title)
       (let* ((expected expected-result)
              (produced tested-expression))
         (unless (equal? expected produced)
           (format #t "*** Expected: ~s\n" expected)
           (format #t "*** Computed: ~s\n" produced)))))))

;; validation helper

(define (validate/same-keys? spec input)
  (equal? (map car spec) (map car input)))

(test-check "validate/same-keys? 0"
  (validate/same-keys? '() '())
  #t)

(test-check "validate/same-keys? 1"
  (validate/same-keys? '((a . b)) '((a . b)))
  #t)

(test-check "validate/same-keys? 2"
  (validate/same-keys? '((a . b)) '((c . b)))
  #f)

(test-check "validate/same-keys? 3"
  (validate/same-keys? '((a . b) (c . d)) '((c . b)))
  #f)

(define (validate/sort assoc)
  (sort assoc (lambda (a b) (string<? (symbol->string (car a))
                                      (symbol->string (car b))))))

(test-check "validate/sort 0"
  (validate/sort '())
  '())

(test-check "validate/sort 1"
  (validate/sort '((a) (c) (b)))
  '((a) (b) (c)))

(test-check "validate/sort 2"
  (validate/sort '((a) (b) (c)))
  '((a) (b) (c)))

(define (validate/throw errors)
  (let ((errors (filter (lambda (v) (not (null? v))) errors)))
    (if (null? errors)
        #t
        (throw 'validation-error errors))))

(define (validate/validate spec input)
  (let ((key (car spec))
        (validator (cdr spec))
        (value (cdr input)))
    (catch 'validation-error
      (lambda ()
        (validator value)
        '())
      (lambda (_ error)
        (cons key error)))))

(test-check "validate/validate 0"
  (validate/validate (cons 'key (lambda (v) (throw 'validation-error "fatal error")))
                     (cons 'key 'any-value))
  (cons 'key "fatal error"))

(test-check "validate/validate 1"
  (validate/validate (cons 'key values)
                     (cons 'key 'any-value))
  '())

(define (validate spec input)
  "Validate INPUT based on SPEC"
  (let ((spec* (validate/sort spec))
        (input* (validate/sort input)))
    (if (validate/same-keys? spec input)
        (validate/throw (map validate/validate spec* input*))
        (throw 'validation-error 'invalid-keys))))

(define (validate/less-than count)
  (lambda (string)
    (if (< (string-length string) count)
        string  ;; return the value to make the validators compose-able
        (throw 'validation-error (format #f "bigger than ~a" count)))))

(test-check "validate 0"
  (validate (list (cons 'key (validate/less-than 10)))
            (list (cons 'key "abc")))
  #t)
  
(test-check "validate 1"
  (catch 'validation-error
    (lambda ()
      (validate (list (cons 'key (validate/less-than 1)))
                (list (cons 'key "abc")))
      #f) ;; test fails
    (lambda (key errors)
      (equal? errors '((key . "bigger than 1")))))
  #t)