Added some tests.
Fixed some things I noticed when testing the tests.
This commit is contained in:
Linus
parent
524933d29f
commit
3908019bbc
4 changed files with 235 additions and 33 deletions
|
|
@ -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 ()
|
||||
|
|
|
|||
2
goof.scm
2
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
242
tests.scm
242
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 <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.
|
||||
|
||||
(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) "[0;32m") ;green
|
||||
((xfail) "[1;32m") ;light green
|
||||
((skip) "[1;34m") ;blue
|
||||
((fail xpass) "[0;31m") ;red
|
||||
((error) "[0;35m")) ;magenta
|
||||
result
|
||||
"[m")))
|
||||
|
||||
(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")
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue