; Copyright (c) 2014-2021, 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.
; 


#|[
Pre- and postconditions made easy
---------------------------------
This egg implements some routines, which are outsourced from
simple-exceptions. In particular macros << and >>, which accept an
argument or result, checks it against zero or more predicates and
returns it in case of success unchanged. Otherwise it prints a
meaningful error message, showing i.a. the offending predicate and the
argument's or result's name. Some are implemented as macros instead of
procedures, because I didn't want an extra parameter with the argument's
or result's name.
Procedure versions of those macros are given as well.
In reimplementing those routines, I changed the syntax a bit, so be
careful, if you used the equally named routines from simple-expressions.

The precondition and postcondition checks are denoted with some
consecutive symbols < and > respectively. There are macro and procedure
versions, the latter denoted with a trailing % and needing an additional
parameter, the name of the value to be checked. All those routines work
the same, they differ only in the error message, they produce in case
some predicate returns #f. The routines named with three symbols < or >
differ from those with two only by an additional parameter naming the
location of the checks.
]|#

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

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


#|[
(checker sym .. ok? ....)
--- procedure ---
creates a checker routine, i.e. a unuary procedure, which returns its
argument unchanged, provided it passes all ok? tests. If not, an error
is generated with location sym, whose default is 'checker.
]|#
(define checker 'checker)

#|[
(checker? xpr)
--- procedure ---
type predicate.
]|#
(define checker? 'checker?)

(let ((in (gensym 'in)) (out (gensym 'out)))

  (set! checker
    (lambda args
      (cond
        ((null? args)
         (error 'checker "correct args are" '(sym .. ok? ....)))
        ((and (null? (cdr args)) (symbol? (car args)))
         (error 'checker "correct args are" '(sym .. ok? ....)))
        (else
          (let ((location (if (symbol? (car args))
                            (car args)
                            'checker))
                (predicates (if (symbol? (car args))
                              (cdr args)
                              args)))
            (lambda (arg)
              (if (and (symbol? arg) (eq? arg in))
                out
                (let loop ((preds predicates))
                  (cond
                    ((null? preds) arg)
                    (((car preds) arg)
                     (loop (cdr preds)))
                    (else
                      (error location
                             "predicate failed"
                             (car preds) arg)))))))))))

  (set! checker?
    (lambda (xpr)
      (and (procedure? xpr)
           (condition-case (eq? (xpr in) out)
             ((exn) #f)))))
  )

#|[
(assert* loc xpr . xprs)
--- macro ---
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 ...)))
    ))

#|[
(named-lambda (name . args) xpr . xprs)
--- macro ---
can be used in place of lambda,
possibly improving error messages
]|#
(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? ...)
--- macro ---
Precondition test.
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? ...)
--- macro ---
Precondition test.
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? ...)
--- macro ---
Postcondition test.
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? ...)
--- macro ---
Postcondition test.
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

#|[
(<<<% loc arg-name arg . tests)
--- procedure ---
Precondition test.
Procedure version of <<<, arg needs to be named.
]|#
(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))))))


#|[
(<<% arg-name arg . tests)
--- procedure ---
Precondition test.
Procedure version of <<, arg needs to be named.
]|#
(define (<<% arg-name arg . tests)
  (apply <<<% '<< arg-name arg tests))

#|[
(>>>% loc result-name result . tests)
--- procedure ---
Postcondition test.
Procedure version of >>>, result needs to be named.
]|#
(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))))))


#|[
(>>% result-name result . tests)
--- procedure ---
Postcondition test.
Procedure version of <<, result needs to be named.
]|#
(define (>>% result-name result . tests)
  (apply >>>% '>> result-name result tests))

#|[
(true? xpr)
--- procedure ---
always true
]|#
(define (true? xpr) #t)

#|[
(false? xpr)
--- procedure ---
always false
]|#
(define (false? xpr) #f)


#|[
(checks)
(checks sym)
--- procedure ---
documentation procedure
]|#
(define checks
  (let (
    (alist '(
      (checker
        procedure:
        (checker sym .. ok? ....)
        "creates a checker routine, i.e. a unuary procedure, which returns its"
        "argument unchanged, provided it passes all ok? tests. If not, an error"
        "is generated with location sym, whose default is 'checker."
        )
      (checker?
        procedure:
        (checker? xpr)
        "type predicate."
        )
      (assert*
        macro:
        (assert* loc xpr . xprs)
        "checks, if its arguments xpr . xprs 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 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."
        )
      (<<
        macro:
        (<< arg arg? ...)
        "Precondition test."
        "Check a procedure argument, arg, against each predicate arg? ..."
        "in sequence and pass it to the procedure in case of success."
        )
      (>>>
        macro:
        (>>> loc result result? ...)
        "Postcondition test."
        "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."
        )
      (>>
        macro:
        (>> result result? ...)
        "Postcondition test."
        "Check a return value of a function, result, against each predicate"
        "result? ...in sequence and return it in case of success."
        )
      (<<<%
        procedure:
        (<<<% loc arg-name arg . tests)
        "Precondition test."
        "Procedure version of <<<, arg needs to be named."
        )
      (<<%
        procedure:
        (<<% arg-name arg . tests)
        "Precondition test."
        "Procedure version of <<, arg needs to be named."
        )
      (>>>%
        procedure:
        (>>>% loc result-name result . tests)
        "Postcondition test."
        "Procedure version of >>>, result needs to be named."
        )
      (>>%
        procedure:
        (>>% result-name result . tests)
        "Postcondition test."
        "Procedure version of <<, result needs to be named."
        )
      (true?
        procedure:
        (true? xpr)
        "always true"
        )
      (false?
        procedure:
        (false? xpr)
        "always false"
        )
      (checks
        procedure:
        (checks)
        (checks sym)
        "with sym: documentation of exported symbol"
        "without sym: list of exported symbols"
        )
        ))
      )
      (case-lambda
        (() (map car alist))
        ((sym)
         (let ((pair (assq sym alist)))
           (if pair
             (for-each print (cdr pair))
             (print "Choose one of " (map car alist))))))))
)