;;;; srfi-45-test.scm -*- Scheme -*- vim: ft=scheme:

(import scheme
  (rename scheme (force r5rs:force) (delay r5rs:delay))
  (rename (chicken base) (promise? r5rs:promise?))
  (only (chicken base) print) ;whence `time'?
  (only (chicken port) with-output-to-string)
  test
  srfi-45)

(test-begin "SRFI 45")

;; Perform, or not, a bounded space test.
;; The infinite tests are not performed by default.

(define-syntax +bounded-space
  (syntax-rules (force)
    ((_ (force ?expr))
      (begin
        (newline)
        (print "+++ Bounded Space Test: (force " '?expr ") +++")
        (time (force ?expr)) ) ) ) )

(define-syntax -bounded-space
  (syntax-rules (force)
    ((_ (force ?expr))
      (begin
        (newline)
        (print "+++ Skipping (Infinite) Bounded Space Test: (force " '?expr ") +++") ) ) ) )

(define-syntax test/string
  (syntax-rules ()
    ((test/string ?msg ?trg ?bdy0 ...)
      (test ?msg ?trg (with-output-to-string (lambda () ?bdy0 ...))) ) ) )

;=========================================================================
; Utilities from TESTS AND BENCHMARKS:
;=========================================================================

(define (infinite-loop) (lazy (infinite-loop)))

(define (stream-drop s index)
  (lazy (if (zero? index) s
            (stream-drop (cdr (force s)) (- index 1)))))

(define (from n)
  (delay (cons n (from (+ n 1)))))

(define (traverse s)
  (lazy (traverse (cdr (force s)))))

; Convenient list deconstructor used below.

(define-syntax test:match
  (syntax-rules ()
    ((test:match exp
       (()      exp1)
       ((h . t) exp2))
     (let ((lst exp))
       (cond ((null? lst)
               exp1)
             ((pair? lst)
              (let ((h (car lst))
                    (t (cdr lst)))
                exp2))
             (else
              'test:match-error))))))

(define (stream-filter p? s)
  (lazy (test:match (force s)
          (()
           (delay '()))
          ((h . t)
           (if (p? h) (delay (cons h (stream-filter p? t)))
               (stream-filter p? t))))))

; The stream-ref procedure below does not strictly need to be lazy.
; It is defined lazy for the purpose of testing safe compostion of
; lazy procedures in the times3 benchmark below (previous
; candidate solutions had failed this).

(define (stream-ref s index)
  (lazy (test:match (force s)
          (()
           'error)
          ((h . t)
           (if (zero? index) (delay h)
               (stream-ref t (- index 1)))))))

(define (times3 n)
  (stream-ref (stream-filter (lambda (x) (zero? (modulo x n))) (from 0)) 3))

;=========================================================================
; TESTS AND BENCHMARKS:
;=========================================================================

(test-group "Output Tests"

  ;use `let' to ensure local scope; use of -strict-types so no rebinding

  (let ()
    (define r (r5rs:delay (begin (display 'hi) (display #\space) 1)))
    (define s (lazy r))
    (define t (lazy s))

    (test/string "R5RS & SRFI-45 test 1" "hi 1\n"
      (print (force t)) ) )

  (let ()
    (define r (delay (values 1 2 3)))
    (define s (lazy r))
    (define t (lazy s))

    (test/string "Multiple values test 1" "(1 2 3)\n"
      (print (receive (force t))) ) )

  (let ()
    (define s (delay (begin (print 'hello) 1)))

    (test/string "Memoization test 1" "hello\n"
      (force s)
      (force s) ) )

  (let ((s (delay (begin (print 'bonjour) 2))))
    (test/string "Memoization test 2" "bonjour\n"
      (+ (force s) (force s))) )

  ; : (pointed out by Alejandro Forero Cuervo)
  (let ()
    (define r (delay (begin (print 'hi) 1)))
    (define s (lazy r))
    (define t (lazy s))

    (test/string "Memoization test 3" "hi\n"
      (force t)
      (force r) ) )

  ; : Stream memoization
  (let ()
    (define (ones)
      (delay (begin
               (print 'ho)
               (cons 1 (ones)))))
    (define s (ones))

    (test/string "Memoization test 4" "ho\nho\nho\nho\nho\n"
      (car (force (stream-drop s 4)))
      (car (force (stream-drop s 4))) ) )

  ; : from R5RS
  (let ()
    (define count 0)
    (define p
      (delay (begin
               (set! count (+ count 1))
               (if (> count x) count
                   (force p)))))
    (define x 5)

    (test/string "Reentrancy test 1" "6\n6\n"
      (print (force p))
      (set! x 10)
      (print (force p)) ) )

  ; : from SRFI 40
  (let ()
    (define f
      (let ((first? (the boolean #t)))
        (delay (if (not first?) 'second
                   (begin
                     (set! first? #f)
                     (force f))))))

    (test/string "Reentrancy test 2" "second\n"
      (print (force f)) ) )

  ; : due to John Shutt
  (let ()
    (define q
      (let ((count 5))
        (define (get-count) count)
        (define p (delay (if (<= count 0) count
                             (begin
                               (set! count (- count 1))
                               (force p)
                               (set! count (+ count 2))
                               count))))
        (list get-count p)))
    (define get-count (car q))
    (define p (cadr q))

    (test/string "Reentrancy test 3" "5\n0\n10\n"
      (print (get-count))
      (print (force p))
      (print (get-count)) ) )

  (test/string "Leak test 6" "0\n"
    (print (force (stream-ref (stream-filter zero? (from 0)) 0))) )

  (test/string "Leak test 7" "21\n"
    (print (force (times3 7))) )

  (test/string "Print Lazy" "#<lazy promise>\n" (print (lazy 1)))
  (test/string "Print Eager" "#<eager promise>\n" (print (eager 1)))
  (test/string "Print R5RS" "#<promise>\n" (print (r5rs:delay 1)))
)

;=========================================================================
; Test leaks:  All the leak tests should run in bounded space.
;=========================================================================

;======================================================================
; Leak test 1: Infinite loop in bounded space.
(-bounded-space (force (infinite-loop)))

;======================================================================
; Leak test 2: Pending memos should not accumulate
;              in shared structures.
(let ()
  (define s (infinite-loop))
  (-bounded-space (force s)) )

;======================================================================
; Leak test 3: Safely traversing infinite stream.

(-bounded-space (force (traverse (from 0))))

;======================================================================
; Leak test 4: Safely traversing infinite stream
;              while pointer to head of result exists.
(let ()
  (define s (traverse (from 0)))
  (-bounded-space (force s)) )

;========================================================================
; Leak test 5: Naive stream-filter should run in bounded space.
;              Simplest case.

(cond-expand
  (compiling
    (+bounded-space (force (stream-filter (lambda (n) (= n 10000000 #;10000000000)) (from 0)))) )
  (else
    (+bounded-space (force (stream-filter (lambda (n) (= n 100000)) (from 0)))) ) )

;========================================================================
; Leak test 6: Another long traversal should run in bounded space.

; Check that evenness is correctly implemented - should terminate:

(let ()
  (cond-expand
    (compiling
      (define s (stream-ref (from 0) 10000000 #;10000000000)) )
    (else
      (define s (stream-ref (from 0) 100000)) ) )
  (+bounded-space (force s)) )

;======================================================================
; Leak test 7: Infamous example from SRFI 40.

(cond-expand
  (compiling
    (+bounded-space (force (times3 10000000 #;10000000000))) )
  (else
    (+bounded-space (force (times3 100000))) ) )

;======================================================================

(test-end "SRFI 45")

(test-exit)