Commit 922b37e0 authored by Alex Sassmannshausen's avatar Alex Sassmannshausen

Add unit tests & fix test failures.

* lens.scm
* tests/lens.scm
parent 69a66e43
......@@ -118,7 +118,7 @@ who's key is K."
(lens (cut assoc k <>)
(lambda (s f)
(map (match-lambda
(((? (cut equal? k <>)) . v) (cons k (f v)))
(((? (cut equal? k <>)) . v) (f v))
(entry entry))
s))))
......@@ -200,8 +200,8 @@ passes the predicate."
return a lens that lenses an element with the consequent if it passes the
predicate, or the alternative if it fails."
(lens
(lambda (s) (if (applies? s) (focus lensT s) (focus lensF s)))
(lambda (s f) (if (applies? s) (over lensT f s) (over lensF f s)))))
(lambda (s) (if (applies? s) (focus true s) (focus false s)))
(lambda (s f) (if (applies? s) (over true f s) (over false f s)))))
;;;; Combinators
......
;; tests/lens.scm --- lens implementation -*- coding: utf-8 -*-
;;
;; Copyright (C) 2018 Alex Sassmannshausen <[email protected]>
;;
;; Author: Alex Sassmannshausen <[email protected]>
;;
;; This file is part of guile-tests.
;;
;; guile-tests 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.
;;
;; guile-tests 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 guile-tests; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA [email protected]
;;; Commentary:
;;
;;; Code:
(define-module (tests lens)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
#:use-module (lens)
#:export ())
(test-begin "Lens Unit Tests")
;;;; laws
(define (first-lens-law title lens s x)
(test-assert title (equal? x (focus lens (put lens x s)))))
(define (second-lens-law title lens s)
(test-assert title (equal? s (put lens (focus lens s) s))))
(define (third-lens-law title lens s a b)
(test-assert title (equal? (put lens a s)
(put lens a (put lens b s)))))
;;;; Lenses
;;;;; identity
(first-lens-law "Identity First Law" (id) 54 47)
(second-lens-law "Identity Second Law" (id) 47)
(third-lens-law "Identity Third Law" (id) 54 44 666)
;;;;; Nth
(first-lens-law "Nth First Law" (nth 2) '(a b c) 47)
(second-lens-law "Nth Second Law" (nth 2) '(a b c))
(third-lens-law "Nth Third Law" (nth 2) '(a b c) 44 666)
;;;;; Fst
(first-lens-law "Fst First Law" (fst) '(a b c) 47)
(second-lens-law "Fst Second Law" (fst) '(a b c))
(third-lens-law "Fst Third Law" (fst) '(a b c) 44 666)
;;;;; Snd
(first-lens-law "Snd First Law" (snd) '(a b c) 47)
(second-lens-law "Snd Second Law" (snd) '(a b c))
(third-lens-law "Snd Third Law" (snd) '(a b c) 44 666)
;;;;; Tail
(first-lens-law "Tail First Law" (tail) '(a b c) 47)
(second-lens-law "Tail Second Law" (tail) '(a b c))
(third-lens-law "Tail Third Law" (tail) '(a b c) 44 666)
;;;;; Key
(first-lens-law "Key First Law" (key 'b) '((a . 5) (b . 7) (c . 9)) '(b . 47))
(second-lens-law "Key Second Law" (key 'b) '((a . 5) (b . 7) (c . 9)))
(third-lens-law "Key Third Law" (key 'b) '((a . 5) (b . 7) (c . 9))
'(b . 44) '(b . 666))
;;;;; Key-Ref
(first-lens-law "Key-Ref First Law" (key-ref 'b) '((a . 5) (b . 7) (c . 9)) '(b . 47))
(second-lens-law "Key-Ref Second Law" (key-ref 'b) '((a . 5) (b . 7) (c . 9)))
(third-lens-law "Key-Ref Third Law" (key-ref 'b) '((a . 5) (b . 7) (c . 9))
'(b . 44) '(b . 666))
;;;;; Select-Keys
;; FIXME: Add tests
;;;;; In
(first-lens-law "In First Law" (in 'b 'c)
'((a . 5) (b . ((a . 5) (c . 9))) (c . 9)) '(c . 47))
(second-lens-law "In Second Law" (in 'b 'c)
'((a . 5) (b . ((a . 5) (c . 9))) (c . 9)))
(third-lens-law "In Third Law" (in 'b 'c)
'((a . 5) (b . ((a . 5) (c . 9))) (c . 9))
'(c . 44) '(c . 666))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment