#|[
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))

;;; (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))
    ((_ loc xpr xpr1 ...)
     (and (assert* loc xpr) (assert* loc xpr1 ...)))
    ))

;;;;;; procedure versions

(define (===% msg loc name arg . tests)
  (cond
    ((null? tests) arg)
    (((car tests) arg)
     (apply ===% msg loc name arg (cdr tests)))
    (else
      (error loc msg name arg (car tests)))))

;(define (==% msg name arg . tests)
;  (apply ===% msg '==% name arg tests))

(define (<<<% loc name arg . tests)
  (apply ===% "precondition violated" loc name arg tests))

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

(define (>>>% loc name arg . tests)
  (apply ===% "postcondition violated" loc name arg tests))

(define (>>% name arg . tests)
  (apply >>>% '>> name arg tests))

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

;(define-syntax ===
;  (er-macro-transformer
;    (lambda (form rename compare?)
;      (let ((%===% (rename '===%))
;            (msg (cadr form))
;            (loc (caddr form))
;            (arg (cadddr form))
;            (tests (cddddr form)))
;        `(,%===% ,msg ,loc ',arg ,arg ,@tests)))))
;
;(define-syntax ==
;  (er-macro-transformer
;    (lambda (form rename compare?)
;      (let ((%==% (rename '==%))
;            (msg (cadr form))
;            (arg (caddr form))
;            (tests (cdddr form)))
;        `(,%==% ,msg '== ',arg ,arg ,@tests)))))

;;; (<< 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 <<
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((%<<% (rename '<<%))
            (arg (cadr form))
            (tests (cddr form)))
        `(,%<<% ',arg ,arg ,@tests)))))

;;; (<<< 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 <<<
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((%<<<% (rename '<<<%))
            (loc (cadr form))
            (arg (caddr form))
            (tests (cdddr form)))
        `(,%<<<% ,loc ',arg ,arg ,@tests)))))

;;; (>> 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 >>
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((%>>% (rename '>>%))
            (result (cadr form))
            (tests (cddr form)))
        `(,%>>% ',result ,result ,@tests)))))

;;; (>>> 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 >>>
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((%>>>% (rename '>>>%))
            (loc (cadr form))
            (result (caddr form))
            (tests (cdddr form)))
        `(,%>>>% ,loc ',result ,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
(define-syntax named-lambda
  (syntax-rules ()
    ((_ (name . args) xpr . xprs)
     (letrec ((name (lambda args xpr . xprs)))
       name))))

;;; (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")
    (<<<
      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")
    (named-lambda
      macro:
      (named-lambda name args xpr . xprs)
      "can be used in place of lambda,"
      "possibly improving error messages")
    )))
    (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