#lang scheme

(require "private/utils.ss"
         "private/random-stream.ss")
(require (schemeunit test)
         (for-syntax (cce text)))

(provide test-random)

(define-syntax (test-random stx)
  (syntax-case stx ()
    [(_ . rest) (syntax/loc stx (test-random/keywords () . rest))]))

(define-syntax (test-random/keywords stx)
  (syntax-case stx ()
    [(_ kvs key val . rest)
     (keyword-literal? #'key)
     (syntax/loc stx
       (test-random/keywords (key val . kvs) . rest))]
    [(_ (test-opt ...) ([lhs rhs opt ...] ...) body ...)
     (with-syntax ([([lhs* rhs* opt* ...] ...)
                    (reverse (syntax->list #'([lhs rhs opt ...] ...)))])
       (syntax/loc stx
         (make-random-test
          '(lhs* ...)
          (gen-random [lhs* rhs* opt* ...] ...)
          (lambda (lhs* ...)
            (with-check-info
             (['lhs lhs] ...)
             body ...))
          test-opt ...)))]))

(define-syntax (gen-random stx)
  (syntax-case stx ()
    [(_) (syntax/loc stx (constant-random-stream null))]
    [(_ [lhs0 rhs0 #:where guard #:limit k] [lhs rhs opt ...] ...)
     (syntax/loc stx
       (make-cons-transducer
        (gen-random [lhs rhs opt ...] ...)
        (lambda (lhs ...) rhs0)
        #:where (lambda (lhs0 lhs ...) guard)
        #:limit k))]
    [(_ [lhs0 rhs0 #:limit k #:where guard] [lhs rhs opt ...] ...)
     (syntax/loc stx
       (gen-random [lhs0 rhs0 #:where guard #:limit k]
                   [lhs rhs opt ...] ...))]
    [(_ [lhs0 rhs0 #:where guard] [lhs rhs opt ...] ...)
     (syntax/loc stx
       (gen-random [lhs0 rhs0 #:where guard #:limit 1000]
                   [lhs rhs opt ...] ...))]
    [(_ [lhs0 rhs0 #:limit k] [lhs rhs opt ...] ...)
     (syntax/loc stx
       (gen-random [lhs0 rhs0 #:where #t #:limit k]
                   [lhs rhs opt ...] ...))]
    [(_ [lhs0 rhs0] [lhs rhs opt ...] ...)
     (syntax/loc stx
       (gen-random [lhs0 rhs0 #:where #t #:limit 1000]
                   [lhs rhs opt ...] ...))]))

(define (make-cons-transducer source f #:where pred #:limit limit)
  (random-stream-transducer
   source
   (lambda (input) (cons (apply f input) input))
   #:filter (lambda (output) (apply pred output))
   #:limit limit))

(define (make-random-test variables stream check
                          #:name [name "randomized test"]
                          #:repeat [repeat 100]
                          #:limit [limit 1000])
  (let* ([stream* (random-stream-transducer stream values #:limit limit)])
    (apply
     test-suite name
     (build-list
      repeat
      (lambda (i)
        (test-case (number->string (add1 i))
          (if (random-stream-empty? stream*)
              (if (= i (sub1 repeat))
                  (error (string->symbol name)
                         "Out of random values.  Failed attempts include:\n\n~a"
                         (format-failures
                          variables
                          (random-stream-failures stream)))
                  (error (string->symbol name) "Out of random values."))
              (apply check (random-stream-next! stream*)))))))))

(define (format-failures reversed-names reversed-values)
  (let* ([names (reverse reversed-names)]
         [vals (map reverse reversed-values)]
         [alists (map (lambda (val) (associate names val)) vals)]
         [strs (map format-failure alists)])
    (apply string-append (add-between strs "\n"))))

(define (format-failure alist)
  (apply string-append (map format-pair alist)))

(define (format-pair pair)
  (format "~s = ~s\n" (car pair) (cdr pair)))

(define (associate names vals)
  (if (or (null? names) (null? vals))
      null
      (cons (cons (car names) (car vals))
            (associate (cdr names) (cdr vals)))))