;;; Guile-QuickCheck
;;; Copyright 2020 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Guile-QuickCheck.
;;;
;;; Guile-QuickCheck is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Guile-QuickCheck is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Guile-QuickCheck.  If not, see
;;; <https://www.gnu.org/licenses/>.

(define-module (quickcheck)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-26)
  #:use-module (quickcheck arbitrary)
  #:use-module (quickcheck generator)
  #:use-module (quickcheck property)
  #:use-module (quickcheck rng)
  #:use-module (quickcheck result)
  #:export (configure-quickcheck
            quickcheck-results
            quickcheck))

(define-immutable-record-type <quickcheck-config>
  (make-quickcheck-config seed stop? give-up? size)
  quickcheck-config?
  (seed quickcheck-config-seed set-quickcheck-config-seed)
  (stop? quickcheck-config-stop? set-quickcheck-config-stop?)
  (give-up? quickcheck-config-give-up? set-quickcheck-config-give-up?)
  (size quickcheck-config-size set-quickcheck-config-size))

(define %quickcheck-config
  (make-parameter
   (make-quickcheck-config
    (random (expt 2 32) (random-state-from-platform))
    (lambda (success-count discard-count)
      (>= success-count 100))
    (lambda (success-count discard-count)
      (cond
       ((= 0 success-count) (>= discard-count 10))
       (else (>= (/ discard-count success-count) 10))))
    (lambda (test-number)
      test-number))))

(define-syntax %configure
  (syntax-rules (seed stop? give-up? size)
    ((_ xform)
     (%quickcheck-config xform))
    ((_ xform (seed value) rest ...)
     (%configure (set-quickcheck-config-seed xform value) rest ...))
    ((_ xform (stop? value) rest ...)
     (%configure (set-quickcheck-config-stop? xform value) rest ...))
    ((_ xform (give-up? value) rest ...)
     (%configure (set-quickcheck-config-give-up? xform value) rest ...))
    ((_ xform (size value) rest ...)
     (%configure (set-quickcheck-config-size xform value) rest ...))))

(define-syntax-rule (configure-quickcheck settings ...)
  (%configure (%quickcheck-config) settings ...))

(define (unique-stamps stamps)
  (define (cons-when-new x xs)
    (if (member x xs string=?) xs (cons x xs)))
  (fold cons-when-new '() stamps))

(define (collect-stamps stamps new-stamps)
  (fold (lambda (stamp stamps)
          (assoc-set! stamps stamp (1+ (or (assoc-ref stamps stamp) 0))))
        stamps
        (unique-stamps new-stamps)))

(define (check-results config test)
  (match-let ((($ <quickcheck-config> seed stop? give-up? size) config))
    (let loop ((test-number 0)
               (success-count 0)
               (discard-count 0)
               (stamps '())
               (rng (make-rng-state seed)))
      (cond
       ((stop? success-count discard-count)
        (values success-count stamps #t))
       ((give-up? success-count discard-count)
        (values success-count stamps #f))
       (else
        (receive (res rng*)
            (generate (testable->generator test) (size test-number) rng)
          (match res
            ((? result-success?) (loop (1+ test-number)
                                       (1+ success-count)
                                       discard-count
                                       (collect-stamps stamps
                                                       (result-stamps res))
                                       rng*))
            ((? result-discard?) (loop (1+ test-number)
                                       success-count
                                       (1+ discard-count)
                                       stamps
                                       rng*))
            ((? result-failure?) (values success-count stamps res)))))))))

(define (quickcheck-results test)
  (check-results (%quickcheck-config) test))

(define (check config test)
  (receive (success-count stamp-counts res)
      (check-results config test)
    (match res
      ((? boolean?)
       (if res
           (format #t "OK, passed ~d test~:p" success-count)
           (format #t "Gave up! Passed only ~d ~test~:p" success-count))
       (if (= 1 (length stamp-counts))
           (format #t " (~d ~a).~%" (cdar stamp-counts) (caar stamp-counts))
           (begin
             (format #t ".~%")
             (for-each (lambda (stamp-count)
                         (format #t "~d ~a.~%"
                                 (cdr stamp-count) (car stamp-count)))
                       stamp-counts)))
       res)
      (($ <result> 'failure stamps args)
       (format #t "Falsifiable after ~d test~:p.~%" (1+ success-count))
       (format #t "Seed: ~d~%" (quickcheck-config-seed config))
       (for-each (match-lambda
                   ((name . val) (format #t "~s = ~s~%" name val)))
                 args)
       #f))))

(define (quickcheck test)
  (check (%quickcheck-config) test))
