#|[
Author: Juergen Lorenz
ju (at) jugilo (dot) de

Copyright (c) 2014-2019, Juergen Lorenz
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

Neither the name of the author nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission. 

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
]|#


(module checks (checks assert*
                <<% << >>% >> <<<% <<< >>>% >>>
                 true? false? named-lambda)

  (import scheme (only (chicken base) assert print case-lambda error)
          (only simple-exceptions raise assert-exception
                argument-exception result-exception))

;;; (assert* loc xpr . xprs)
;;; ------------------------
;;; checks, if its arguments xpr . xprs are not #f.
(define-syntax assert*
  (syntax-rules ()
    ((_ loc xpr)
     ;(assert xpr loc "assertion violated" 'xpr))
     (or xpr (raise (assert-exception loc 'xpr))))
    ((_ loc xpr xpr1 ...)
     (and (assert* loc xpr) (assert* loc xpr1 ...)))
    ))

(define-syntax named-lambda
  (syntax-rules ()
    ((_ (name . args) xpr . xprs)
     (letrec ((name (lambda args xpr . xprs)))
       name))))

;;;;;;;;;;; the macro versions below avoid the naming of arg or result

;;; (<<< loc arg arg? ...)
;;; ----------------------
;;; check a procedure argument, arg, against each predicate arg? ...
;;; in sequence and pass it to the procedure in case of success.
;;; loc names the location in the error message.
(define-syntax <<<
  (syntax-rules ()
    ((_ loc arg)
     arg)
    ((_ loc arg ok?)
     (if (ok? arg)
       arg
       (raise (argument-exception loc '(ok? arg)))))
       ;(error loc "precondition violated" '(ok? arg))))
    ((_ loc arg ok? ok1? ...)
     (if (ok? arg)
       (<<< loc arg ok1? ...)
       (raise (argument-exception loc '(ok? arg)))))
       ;(error loc "precondition violated" (ok? arg))))
    ))

;;; (<< arg arg? ...)
;;; -----------------
;;; check a procedure argument, arg, against each predicate arg? ...
;;; in sequence and pass it to the procedure in case of success.
(define-syntax <<
  (syntax-rules ()
    ((_ arg ok? ...)
     (<<< '<< arg ok? ...))))

;;; (>>> loc result result? ...)
;;; ----------------------------
;;; check a return value of a function, result, against each predicate
;;; result? ...in sequence and return it in case of success.
;;; loc names the location in case of error.
(define-syntax >>>
  (syntax-rules ()
    ((_ loc result)
     result)
    ((_ loc result ok?)
     (if (ok? result)
       result
       (raise (result-exception loc '(ok? result)))))
       ;(error loc "postcondition violated" '(ok? result))))
    ((_ loc result ok? ok1? ...)
     (if (ok? result)
       (>>> loc result ok1? ...)
       (raise (result-exception loc '(ok? result)))))
       ;(error loc "postcondition violated" '(ok? result))))
    ))

;;; (>> result result? ...)
;;; -----------------------
;;; check a return value of a function, result, against each predicate
;;; result? ...in sequence and return it in case of success.
(define-syntax >>
  (syntax-rules ()
    ((_ result ok? ...)
     (>>> '>> result ok? ...))))

;;;;;; procedure versions need to name arg and result respectively

(define (<<<% loc arg-name arg . tests)
  (let loop ((tests tests))
    (cond
      ((null? tests) arg)
      (((car tests) arg)
       (loop (cdr tests)))
      (else (raise
              (argument-exception loc
                                  `(,(car tests) ,arg-name)))))))
      ;(else (raise
      ;      (error loc 
      ;             "precondition violated"
      ;             `(,(car tests) ,arg-name))))))


(define (<<% arg-name arg . tests)
  (apply <<<% '<< arg-name arg tests))

(define (>>>% loc result-name result . tests)
  (let loop ((tests tests))
    (cond
      ((null? tests) result)
      (((car tests) result)
       (loop (cdr tests)))
      (else (raise
              (result-exception loc
                                `(,(car tests) ,result-name)))))))
      ;(else (error loc 
      ;             "postcondition violated"
      ;             `(,(car tests) ,result-name))))))


(define (>>% result-name result . tests)
  (apply >>>% '>> result-name result tests))

(define (true? xpr) #t)
(define (false? xpr) #f)

;;; (named-lambda (name . args) xpr . xprs)
;;; -----------------------------------
;;; can replace anonymous procedures in << and >>
;;; to improve error messages
;;; (checks [sym])
;;; -------------------------
;;; documentation procedure
(define checks
  (let ((als '(
    (checks
      procedure:
      (checks sym ..)
      "documentation procedure")
    (assert*
      macro:
      (assert* loc xpr ....)
      "checks, if its arguments xpr .... are  not #f")
    (named-lambda
      macro:
      (named-lambda (name . args) xpr . xprs)
      "can be used in place of lambda,"
      "possibly improving error messages")
    (<<<
      macro:
      (<<< loc arg arg? ...)
      "precondition test:"
      "check arg against each predicate arg? in sequence"
      "and return it in case of success."
      "Otherwise print an error message with the"
      "offending predicate at location loc.")
    (<<
      macro:
      (<<< arg arg? ...)
      "precondition test:"
      "check arg against each predicate arg? in sequence"
      "and return it in case of success."
      "Otherwise print an error message with the"
      "offending predicate")
    (>>>
      macro:
      (<<< loc result result? ...)
      "postcondition test:"
      "check result against each predicate result? in sequence"
      "and return it in case of success."
      "Otherwise print an error message with the"
      "offending predicate at location loc.")
    (>>
      macro:
      (<<< result result? ...)
      "postcondition test:"
      "check result against each predicate result? in sequence"
      "and return it in case of success."
      "Otherwise print an error message with the"
      "offending predicate.")
    (<<<%
      procedure:
      (<<<% loc name arg arg? ...)
      "precondition test:"
      "check arg against each predicate arg? in sequence"
      "and return it in case of success."
      "Otherwise print an error message with the"
      "offending predicate at location loc with arg-name name.")
    (<<%
      procedure:
      (<<% name arg arg? ...)
      "precondition test:"
      "check arg against each predicate arg? in sequence"
      "and return it in case of success."
      "Otherwise print an error message with the"
      "offending predicate and arg-name name")
    (>>>%
      procedure:
      (>>>% loc name result result? ...)
      "postcondition test:"
      "check result against each predicate result? in sequence"
      "and return it in case of success."
      "Otherwise print an error message with the"
      "offending predicate at location loc with result-name name.")
    (>>%
      procedure:
      (<<% name result result? ...)
      "postcondition test:"
      "check result against each predicate result? in sequence"
      "and return it in case of success."
      "Otherwise print an error message with the"
      "offending predicate and result-name name.")
    (true?
      procedure?
      (true? xpr)
      "returns always #t")
    (false?
      procedure?
      (false? xpr)
      "returns always #f")
    )))
    (case-lambda
      (()
       (map car als))
      ((sym)
       (let ((pair (assq sym als)))
         (if pair
           (for-each print (cdr pair))
           (error "Not in list"
                  sym
                  (map car als))))))))

  ) ; module checks