;;; 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 property)
  #:use-module (ice-9 match)
  #:use-module (quickcheck arbitrary)
  #:use-module (quickcheck generator)
  #:use-module (quickcheck result)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:export (property?
            property
            testable?
            testable->generator
            test-when
            stamp-test
            stamp-test-when))

(define-record-type <property>
  (make-property names gen/arbs proc)
  property?
  (names property-names)
  (gen/arbs property-gen/arbs)
  (proc property-proc))

(define-syntax-rule (property ((name gen/arb) ...) exp exp* ...)
  (make-property
   (list 'name ...)
   (list gen/arb ...)
   (lambda (name ...) exp exp* ...)))

(define (testable? test)
  (or (property? test)
      (boolean? test)
      (result? test)
      (generator? test)))

(define (testable->generator test)
  (match test
    ((? property?) (property->generator test))
    ((? boolean?) (generator-return (boolean->result test)))
    ((? result?) (generator-return test))
    ((? generator?) test)))

(define (gen/arb->generator gen/arb)
  (match gen/arb
    ((? generator?) gen/arb)
    ((? arbitrary?) (arbitrary-gen gen/arb))))

(define (generate-list gens)
  (if (null? gens)
      (generator-return '())
      (generator-let* ((elem (car gens))
                       (rest (generate-list (cdr gens))))
        (generator-return (cons elem rest)))))

(define (property->generator prop)
  (match-let* ((($ <property> names gen/arbs proc) prop)
               (args-gen (generate-list (map gen/arb->generator gen/arbs))))
    (generator-let* ((args args-gen) 
                     (res (testable->generator (apply proc args))))
      (generator-return
       (result-args-append (fold-right acons '() names args) res)))))

(define-syntax-rule (test-when condition test)
  (if condition
      test
      (property () (make-result 'discard '() '()))))

(define (stamp-test stamp test)
  (let ((stamp (if (string? stamp) stamp (format #f "~s" stamp))))
    (generator-let* ((res (testable->generator test)))
      (generator-return (result-stamps-cons stamp res)))))

(define-syntax-rule (stamp-test-when condition stamp test)
  (if condition
      (stamp-test stamp test)
      test))
