goof-loop/tests.scm

;; This testrunner is shamelessly stolen from rednosehacker.com
;; and is copyrighted as
;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2019 Alex Sassmannshausen <alex@pompo.co>
;;; Copyright © 2019 Jérémy Korwin-Zmijowski <jeremy@korwin-zmijowski.fr>
;;;
;;; This program 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.
;;;
;;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; Thus, this file is under the GPL v.3 or any later version.

(use-modules (srfi srfi-64)
             (goof)
             (ice-9 pretty-print)
             (srfi srfi-26))

(define* (test-display field value  #:optional (port (current-output-port))
                       #:key pretty?)
  "Display 'FIELD: VALUE\n' on PORT."
  (if pretty?
      (begin
        (format port "~A:~%" field)
        (pretty-print value port #:per-line-prefix "+ "))
      (format port "~A: ~S~%" field value)))

(define* (result->string symbol)
  "Return SYMBOL as an upper case string.  Use colors when COLORIZE is #t."
  (let ((result (string-upcase (symbol->string symbol))))
    (string-append (case symbol
                     ((pass)       "")  ;green
                     ((xfail)      "")  ;light green
                     ((skip)       "")  ;blue
                     ((fail xpass) "")  ;red
                     ((error)      "")) ;magenta
                   result
                   "")))

(define* (test-runner-kata)

  (define (test-on-test-end-kata runner)
    (let* ((results (test-result-alist runner))
           (result? (cut assq <> results))
           (result  (cut assq-ref results <>)))
      (if (equal? 'fail (result 'result-kind))
	      (begin
	        (newline)
	        (format #t "~a ~A~%"
		            (result->string (result 'result-kind))
		            (result 'test-name))
	        (when (result? 'expected-value)
              (test-display "expected-value" (result 'expected-value)))
	        (when (result? 'expected-error)
              (test-display "expected-error" (result 'expected-error) #:pretty? #t))
	        (when (result? 'actual-value)
              (test-display "actual-value" (result 'actual-value)))
	        (when (result? 'actual-error)
	          (test-display "actual-error" (result 'actual-error) #:pretty? #t))
	        (newline))
	      (begin
	        (format #t "~a ~A~%"
		            (result->string (result 'result-kind))
		            (result 'test-name))))))

  (let ((runner (test-runner-null)))
    (test-runner-on-test-end! runner test-on-test-end-kata)
    runner))

(test-runner-current (test-runner-kata))


(test-begin "basic workings")
(test-equal
    "basic syntax 1"
  (loop ((:for a (up-from 0 3)) (:acc acc (listing a)))
    => acc)
  '(0 1 2))

(test-equal ":when clause"
  (loop ((:for a (up-from 0 3))
         (:when (odd? a))
         (:acc lst (listing a)))
    => lst)
  '(1))

(test-equal ":unless clause"
  (loop ((:for a (up-from 0 3))
         (:unless (even? a))
         (:acc lst (listing a)))
    => lst)
  '(1))

(test-equal ":when subloop"
  (loop/list ((a (up-from 0 4)) (:when (odd? a)) (b (up-from 0 2)))
    (cons a b))
  '((1 . 0) (1 . 1) (3 . 0) (3 . 1)))

(test-equal ":break"
  (loop/list ((a (up-from 0)) (:break (= a 3)))
    a)
  '(0 1 2))

(test-equal ":final"
  (loop/list ((a (up-from 0)) (:final (= a 3)))
    a)
  '(0 1 2 3))

(test-equal ":let and :let*"
  (loop/list ((a (up-from 0 5)) (:let b (+ a 1)) (:let* c (+ b 1)))
    c)
  '(2 3 4 5 6))

(test-equal "putting things together"
  (loop ((:for a (in-list '(((1) (2)) ((3) (4)) ((5) (6 7)))))
         (:when #t)
         (:for b (in-list a))
         :subloop
         (:for c (in-list b))
         (:acc acc (listing c)))
    => acc)
  '(1 2 3 4 5 6 7))

(test-equal "putting things together 2"
  (loop ((:for a (in-list '(1 2 3)))
         (:acc oa (summing a))
         :subloop
         (:for b (up-from a (:to (+ a 2))))
         (:acc ob (listing b)))
    => (cons oa ob))
  '(6 1 2 2 3 3 4))
(test-end "basic workings")



(test-begin "simple forms")
(test-equal "loop/first"
  (loop/first ((a (in-list '(-1 1 2 3 4 5)))
               (:when (even? a)))
    a)
  2)

(test-equal "loop/last"
  (loop/last ((a (up-from 0 10)) (:when (even? a)))
    a)
  8)

(test-equal "loop/list"
  (loop/list ((a (up-from 0 10))
              (:break (> a 4)))
    a)
  '(0 1 2 3 4))

(test-equal "loop/product"
  (loop/product ((a (up-from 1 5)))
    a)
  24)

(test-equal "loop/sum"
  (loop/sum ((a (up-from 1 5)))
    a)
  10)

(test-equal "loop/and true"
  (loop/and ((a (in-list '(1 1 1 1 1))))
    (= a 1))
  #t)

(test-equal "loop/and false"
  (loop/and ((a (in-list '(1 2 3 4 banana))))
    (< a 4))
  #f)

(test-equal "loop/or true"
  (loop/or ((a (in-list '(1 2 3 4 #f))))
    (and (= 4 a) a))
  4)

(test-equal "loop/or false"
  (loop/or ((a (in-list '(1 3 5 banana))))
    (> a 3))
  #t)

(test-equal  "loop/list/parallel"
  (loop/list/parallel ((a (in-list '(1 2 3 4))))
    (+ a 1))
  '(2 3 4 5))
(test-end "simple-forms")


(test-begin ":for-clauses")
(test-equal "in-list"
  (loop name  ((:for elt pair (in-list '(1 2 3))))
        (if (null? (cdr pair))
            (list elt)
            (cons* elt ': (name))))
  '(1 : 2 : 3))

;; suming 1 3 5 7 9 => 25
(test-equal "up-from-1"
  (loop/sum ((a (up-from 1 (:to 10) (:by 2))))
    a)
  25)

(test-equal "up-from-2"
  (loop/sum ((a (up-from 1 10 2)))
    a)
  25)

(test-equal "up-from unbounded"
  (loop/list ((a (up-from 1)) (b (in-list '(1 2 3))))
    (+ a b))
  '(2 4 6))

(test-equal "up-from unbounded 2"
  (loop/list ((a (up-from 1 (:by 2))) (b (in-list '(1 3 5))))
    (+ a b))
  '(2 6 10))
(test-end ":for-clauses")