#|[
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 (assert* << >> <<< >>> true? false?)
  (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 ...)))
    ))

;;;;; (<<< loc arg-name arg . preds)
;;;;; ------------------------------
;;;;; pass in an argument, arg, after having it checked against each
;;;;; predicate in sequence
;;;;; loc and arg-name are used only in the error message.
;;;(define (<<< loc name arg . preds)
;;;  (let loop ((preds preds))
;;;    (cond
;;;      ((null? preds)
;;;       arg)
;;;      (((car preds) arg)
;;;       (loop (cdr preds)))
;;;      (else
;;;        (error loc "precondition violated" name arg (car preds))
;;;        ))))
;;;;;; (<< arg-name arg arg? ...)
;;;;;; --------------------------
;;;;;; pass in an argument, arg, after having it checked against each
;;;;;; predicate, arg?, in sequence
;;;;;; arg-name is used only in the error message.
;;;(define (<< name arg . preds)
;;;  (apply <<< '<< name arg preds))


(define-syntax ===  ; hidden
  (syntax-rules ()
    ((_ msg loc x) x)
    ((_ msg loc x x?)
     (if (x? x)
       x
       (error loc msg 'x x x?)))
    ((_ msg loc x x? x1? ...)
     (if (x? x)
       (=== msg loc x x1? ...)
       (error loc msg 'x x x?)))
    ))

;;;;;;;;;;; the macro version below avoids the naming of arg
;;; (<<< 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? ...)
     (=== "precondition violated" loc arg arg? ...))))
;    ((_ loc arg) arg)
;    ((_ loc arg arg?)
;     (if (arg? arg)
;       arg
;       (error loc "precondition violated" 'arg arg arg?)))
;    ((_ loc arg arg? arg1? ...)
;     (if (arg? arg)
;       (<<< loc arg arg1? ...)
;       (error loc "precondition violated" 'arg arg 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 arg? ...)
     (<<< '<< arg arg? ...))))

;;; (>>> 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? ...)
     (=== "postcondition violated" loc result result? ...))))
;    ((_ loc result) result)
;    ((_ loc result result?)
;     (if (result? result)
;       result
;       (error loc "postcondition violated" 'result result result?)))
;    ((_ loc result result? result1? ...)
;     (if (result? result)
;       (>>> loc result result1? ...)
;       (error loc "postcondition violated" 'result result 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 result? ...)
     (>>> '>> result result? ...))))

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

;;; (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.")
    (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