(library (srfi n78)
  (export check 
	  =>
          check-ec 
          check-report
          check-set-mode!
          check-reset!
          check-passed?)
  (import (rnrs)
	  (rnrs mutable-pairs)
	  (srfi n42))
  
  (define (make-box v) (cons v '()))
  (define (box-ref b) (car b))
  (define (box-set! b v) (set-car! b v))
	  

;; SRFI 78 Reference Implementation
;; http://srfi.schemers.org/srfi-78/check.scm

;; See *R6RS* comments for small R6RS specific changes:
;;
;; The two initialization expressions were moved to the end of the
;; library (R6RS disallows definitions after expressions).
;;
;; The state, check:{mode,correct,failed}, is boxed rather than held
;; in global bindings which are mutated (R6RS disallows mutated
;; exports, in this case, implicit ones).

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; <PLAINTEXT>
; Copyright (c) 2005-2006 Sebastian Egner.
;
; Permission is hereby granted, free of charge, to any person obtaining
; a copy of this software and associated documentation files (the
; ``Software''), to deal in the Software without restriction, including
; without limitation the rights to use, copy, modify, merge, publish,
; distribute, sublicense, and/or sell copies of the Software, and to
; permit persons to whom the Software is furnished to do so, subject to
; the following conditions:
;
; The above copyright notice and this permission notice shall be
; included in all copies or substantial portions of the Software.
;
; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;
; -----------------------------------------------------------------------
;
; Lightweight testing (reference implementation)
; ==============================================
;
; Sebastian.Egner@philips.com
; in R5RS + SRFI 23 (error) + SRFI 42 (comprehensions)
;
; history of this file:
;   SE, 25-Oct-2004: first version based on code used in SRFIs 42 and 67
;   SE, 19-Jan-2006: (arg ...) made optional in check-ec
;
; Naming convention "check:<identifier>" is used only internally.

; -- portability --

; PLT:      (require (lib "23.ss" "srfi") (lib "42.ss" "srfi"))
; Scheme48: ,open srfi-23 srfi-42

; -- utilities --

(define check:write write)

; You can also use a pretty printer if you have one.
; However, the output might not improve for most cases
; because the pretty printers usually output a trailing
; newline.

; PLT:      (require (lib "pretty.ss")) (define check:write pretty-print)
; Scheme48: ,open pp (define check:write p)

; -- mode --

; *R6RS*: Replaced mutable variable with a box.
;(define check:mode #f)
(define check:mode (make-box #f))

(define (check-set-mode! mode)
  (box-set! check:mode
        (case mode
          ((off)           0)
          ((summary)       1)
          ((report-failed) 10)
          ((report)        100)
          (else (error "unrecognized mode" mode)))))

; *R6RS* must appear after definitions.
;(check-set-mode! 'report)

; -- state --

; *R6RS*: Replaced mutable variable with a box.
;(define check:correct #f)
;(define check:failed  #f)
(define check:correct (make-box #f))
(define check:failed  (make-box #f))

(define (check-reset!)
  (box-set! check:correct 0)
  (box-set! check:failed   '()))

(define (check:add-correct!)
  (box-set! check:correct (+ (box-ref check:correct) 1)))

(define (check:add-failed! expression actual-result expected-result)
  (box-set! check:failed
        (cons (list expression actual-result expected-result)
              (box-ref check:failed))))

; *R6RS* must appear after definitions.
;(check-reset!)

; -- reporting --

(define (check:report-expression expression)
  (newline)
  (check:write expression)
  (display " => "))

(define (check:report-actual-result actual-result)
  (check:write actual-result)
  (display " ; "))

(define (check:report-correct cases)
  (display "correct")
  (if (not (= cases 1))
      (begin (display " (")
             (display cases)
             (display " cases checked)")))
  (newline))

(define (check:report-failed expected-result)
  (display "*** failed ***")
  (newline)
  (display " ; expected result: ")
  (check:write expected-result)
  (newline))

(define (check-report)
  (if (>= (box-ref check:mode) 1)
      (begin
        (newline)
        (display "; *** checks *** : ")
        (display (box-ref check:correct))
        (display " correct, ")
        (display (length (box-ref check:failed)))
        (display " failed.")
        (if (or (null? (box-ref check:failed)) (<= (box-ref check:mode) 1))
            (newline)
            (let* ((w (car (reverse (box-ref check:failed))))
                   (expression (car w))
                   (actual-result (cadr w))
                   (expected-result (caddr w)))                  
              (display " First failed example:")
              (newline)
              (check:report-expression expression)
              (check:report-actual-result actual-result)
              (check:report-failed expected-result))))))

(define (check-passed? expected-total-count)
  (and (= (length (box-ref check:failed)) 0)
       (= (box-ref check:correct) expected-total-count)))
       
; -- simple checks --

(define (check:proc expression thunk equal expected-result)
  (case (box-ref check:mode)
    ((0) #f)
    ((1)
     (let ((actual-result (thunk)))
       (if (equal actual-result expected-result)
           (check:add-correct!)
           (check:add-failed! expression actual-result expected-result))))
    ((10)
     (let ((actual-result (thunk)))
       (if (equal actual-result expected-result)
           (check:add-correct!)
           (begin
             (check:report-expression expression)
             (check:report-actual-result actual-result)
             (check:report-failed expected-result)
             (check:add-failed! expression actual-result expected-result)))))
    ((100)
     (check:report-expression expression)
     (let ((actual-result (thunk)))
       (check:report-actual-result actual-result)
       (if (equal actual-result expected-result)
           (begin (check:report-correct 1)
                  (check:add-correct!))
           (begin (check:report-failed expected-result)
                  (check:add-failed! expression 
				     actual-result 
				     expected-result)))))
    (else (error "unrecognized check:mode" (box-ref check:mode))))
  (if #f #f))

(define-syntax check
  (syntax-rules (=>)
    ((check expr => expected)     
     (check expr (=> equal?) expected))
    ((check expr (=> equal) expected)
     (if (>= (box-ref check:mode) 1)
	 (check:proc 'expr (lambda () expr) equal expected)))))

; -- parametric checks --

(define (check:proc-ec w)
  (let ((correct? (car w))
        (expression (cadr w))
        (actual-result (caddr w))
        (expected-result (cadddr w))
	(cases (car (cddddr w))))
    (if correct?
        (begin (if (>= (box-ref check:mode) 100)
                   (begin (check:report-expression expression)
                          (check:report-actual-result actual-result)
                          (check:report-correct cases)))
               (check:add-correct!))
        (begin (if (>= (box-ref check:mode) 10)
                   (begin (check:report-expression expression)
                          (check:report-actual-result actual-result)
                          (check:report-failed expected-result)))
               (check:add-failed! expression 
				  actual-result 
				  expected-result)))))

(define-syntax check-ec:make
  (syntax-rules (=>)
    ((check-ec:make qualifiers expr (=> equal) expected (arg ...))
     (if (>= (box-ref check:mode) 1)
         (check:proc-ec
	  (let ((cases 0))
	    (let ((w (first-ec 
		      #f
		      qualifiers
		      (:let equal-pred equal)
		      (:let expected-result expected)
		      (:let actual-result
                            (let ((arg arg) ...) ; (*)
                              expr))
		      (begin (set! cases (+ cases 1)))
		      (if (not (equal-pred actual-result expected-result)))
		      (list (list 'let (list (list 'arg arg) ...) 'expr)
			    actual-result
			    expected-result
			    cases))))
	      (if w
		  (cons #f w)
		  (list #t 
			'(check-ec qualifiers 
				   expr (=> equal) 
				   expected (arg ...))
			(if #f #f)
		        (if #f #f)
			cases)))))))))

; (*) is a compile-time check that (arg ...) is a list
; of pairwise disjoint bound variables at this point.

(define-syntax check-ec
  (syntax-rules (nested =>)
    ((check-ec expr => expected)
     (check-ec:make (nested) expr (=> equal?) expected ()))
    ((check-ec expr (=> equal) expected)
     (check-ec:make (nested) expr (=> equal) expected ()))
    ((check-ec expr => expected (arg ...))
     (check-ec:make (nested) expr (=> equal?) expected (arg ...)))
    ((check-ec expr (=> equal) expected (arg ...))
     (check-ec:make (nested) expr (=> equal) expected (arg ...)))

    ((check-ec qualifiers expr => expected)
     (check-ec:make qualifiers expr (=> equal?) expected ()))
    ((check-ec qualifiers expr (=> equal) expected)
     (check-ec:make qualifiers expr (=> equal) expected ()))
    ((check-ec qualifiers expr => expected (arg ...))
     (check-ec:make qualifiers expr (=> equal?) expected (arg ...)))
    ((check-ec qualifiers expr (=> equal) expected (arg ...))
     (check-ec:make qualifiers expr (=> equal) expected (arg ...)))

    ((check-ec (nested q1 ...) q etc ...)
     (check-ec (nested q1 ... q) etc ...))
    ((check-ec q1 q2             etc ...)
     (check-ec (nested q1 q2)    etc ...))))

; *R6RS* These expressions must appear after the definitions.
(check-set-mode! 'report)
(check-reset!)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
) ; end library