From 3908019bbc59375b0c954f039ba4f35f1bcf95f0 Mon Sep 17 00:00:00 2001 From: Linus Date: Mon, 22 Mar 2021 19:29:16 +0100 Subject: [PATCH] Added some tests. Fixed some things I noticed when testing the tests. --- goof-impl.scm | 12 +-- goof.scm | 2 +- goof/iterators.scm | 12 +-- tests.scm | 242 +++++++++++++++++++++++++++++++++++++++++---- 4 files changed, 235 insertions(+), 33 deletions(-) diff --git a/goof-impl.scm b/goof-impl.scm index 91a6365..b944a41 100644 --- a/goof-impl.scm +++ b/goof-impl.scm @@ -256,7 +256,7 @@ (((ff-cur ... new-for-finals ...) (ff-above ...)) . ff-rest) ul uw ub uf clauses . body)) ((cl err ...) - '(cl err ...)))) + (cl err ...)))) (define-syntax user-let (syntax-rules (:let :let*) @@ -474,7 +474,7 @@ ((_ o n (s ...) ((:when expr) clauses ...) . body) (forify* o n (s ... (:when expr)) (clauses ...) . body)) ((_ o n (s ...) ((:unless expr) clauses ...) . body) - (forify* o n (s ... (:when expr)) (clauses ...) . body)) + (forify* o n (s ... (:unless expr)) (clauses ...) . body)) ((_ o n (s ...) ((:break expr) clauses ...) . body) (forify* o n (s ... (:break expr)) (clauses ...) . body)) ((_ o n (s ...) ((:final expr) clauses ...) . body) @@ -534,10 +534,10 @@ (syntax-rules () ((n (clauses ...) body ...) (forify (n (clauses ...) body ...) - loop-name (clauses ... (%acc acc (folding sentinel))) - => (if (eq? sentinel acc) #f acc) - (let ((result (let () body ...))) - (loop-name (=> acc result))))))) + loop-name () (clauses ... (%acc acc (folding sentinel))) + => (if (eq? sentinel acc) #f acc) + (let ((result (let () body ...))) + (loop-name (=> acc result))))))) (define-syntax loop/and (syntax-rules () diff --git a/goof.scm b/goof.scm index a2c0127..6a2172a 100644 --- a/goof.scm +++ b/goof.scm @@ -91,7 +91,7 @@ ;; This part is only for an auxilary macro that checks whether the :for or :acc clause is ;; actually defined. The reason I use parameters here is because guile modules are immutable by ;; default and I had to wrap it in something. Paremeters are available in the default environment -;; boxer are not. +;; boxes are not. (define valid-for-clauses (make-parameter (list #'in #'in-list #'in-lists #'in-vector #'in-reverse-vector #'in-string #'in-reverse-string diff --git a/goof/iterators.scm b/goof/iterators.scm index dc7f48c..8fc5b86 100644 --- a/goof/iterators.scm +++ b/goof/iterators.scm @@ -40,13 +40,13 @@ (define-syntax in-list (syntax-rules (:for) - ((in-list:for ((var) source) next . rest) + ((in-list :for ((var) source) next . rest) (in-list :for ((var cursor) source) next . rest)) - ((in-list:for ((var cursor) source) next . rest) + ((in-list :for ((var cursor) source) next . rest) (in-list :for ((var cursor succ) source) next . rest)) - ((in-list:for ((var cursor succ) (source)) next . rest) + ((in-list :for ((var cursor succ) (source)) next . rest) (in-list :for ((var cursor succ) (source cdr)) next . rest)) - ((in-list:for ((var cursor succ) (source step)) next . rest) + ((in-list :for ((var cursor succ) (source step)) next . rest) (next ;; outer let bindings, bound outside the loop, unchanged during the loop () @@ -63,9 +63,9 @@ . rest)) ;; Generator-clauses - ((in-listlst) + ((in-list lst) (gen-list lst)) - ((in-list(var) (expr step)) + ((in-list (var) (expr step)) (gen-list lst step)))) (define gen-list diff --git a/tests.scm b/tests.scm index 1e82d58..4eed26c 100644 --- a/tests.scm +++ b/tests.scm @@ -1,25 +1,227 @@ -;; This is just a file with things that should be written as a test. Dump file. +;; This testrunner is shamelessly stolen from rednosehacker.com +;; and is copyrighted as +;; Copyright © 2015, 2016 Mathieu Lirzin +;;; Copyright © 2019 Alex Sassmannshausen +;;; Copyright © 2019 Jérémy Korwin-Zmijowski +;;; +;;; 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 . +;; +;; Thus, this file is under the GPL v.3 or any later version. -(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) +(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)) -(loop ((:for a (in-list '((1 2) (3 4) (5 6)))) - :subloop - (:for b (in-list a)) - (:acc acc (listing b))) - => acc) +(test-begin "basic workings") +(test-equal + "basic syntax 1" + (loop ((:for a (up-from 0 3)) (:acc acc (listing a))) + => acc) + '(0 1 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))) - => (values oa ob)) -;; Should return 6 and (1 2 2 3 3 4) +(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")