From ffd0a028aefd203b4a42ded1e5a592e1b4d92dd7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 4 Dec 2023 01:58:26 +0100
Subject: Complete rewrite of the lens system.

The old "lens" system was more of nested accessors. This rewrites them
to be much better, at the cost of some extra up-front complexity.

Beside the change in lenses, and all required adjustments, also adds
lens creation to the define-type macro.
---
 tests/unit/util/hnh-util-lens.scm | 68 ++++++++++++++++++++++++---------------
 1 file changed, 42 insertions(+), 26 deletions(-)

(limited to 'tests/unit/util/hnh-util-lens.scm')

diff --git a/tests/unit/util/hnh-util-lens.scm b/tests/unit/util/hnh-util-lens.scm
index 0f4af6cb..6e8b5831 100644
--- a/tests/unit/util/hnh-util-lens.scm
+++ b/tests/unit/util/hnh-util-lens.scm
@@ -2,60 +2,76 @@
   :use-module (srfi srfi-64)
   :use-module (srfi srfi-64 test-error)
   :use-module (srfi srfi-88)
+  :use-module ((hnh util) :select (enumerate))
   :use-module (hnh util lens))
 
 
 (define first (ref 0))
 
-(test-equal '((1)) (first '(((1)))))
-(test-equal '((2)) (set '(((1))) (compose-lenses first first) 2))
-(test-equal '(((2))) (set '(((1))) (compose-lenses first first first) 2))
+(test-equal '((1)) (get '(((1))) first))
+
+(test-equal '((2)) (set '(((1))) (compose-lens first first) 2))
+(test-equal '(((2))) (set '(((1))) (compose-lens first first first) 2))
 
 
 ;; (list-change (iota 10) 5 'Hello)
 ;; => (0 1 2 3 4 Hello 6 7 8 9)
 
-(test-equal '(1 (10) 3) (set '(1 (2) 3) (compose-lenses (ref 1) (ref 0)) 10))
-(test-equal '(1 (10) 3) (set '(1 (2) 3) (ref 1) (ref 0) 10))
+(test-equal '(1 (10) 3) (set '(1 (2) 3)
+                             (compose-lens (ref 1) (ref 0))
+                             10))
+(test-equal '(1 (10) 3) (set '(1 (2) 3)
+                             (compose-lens (ref 1) (ref 0))
+                             10))
 
 ;; (set (list (iota 10)) first first 11)
 
-(define cadr* (compose-lenses cdr* car*))
+(define cadr* (compose-lens cdr* car*))
 
 (test-group "Primitive lenses get and set"
   (define lst '(1 2 3 4 5))
-  (test-equal 1 (car* lst))
-  (test-equal '(2 3 4 5) (cdr* lst))
+  (test-equal 1 (get lst car*))
+  (test-equal '(2 3 4 5) (get lst cdr*))
 
   (test-equal '(10 2 3 4 5)
-    (car* lst 10)))
+    (set lst car* 10)))
 
 (test-group "Primitive lens composition"
   (define lst '(1 2 3 4 5))
-  (test-equal 2 (cadr* lst))
-  (test-equal '(1 10 3 4 5) (cadr* lst 10)))
+  (test-equal 2 (get lst cadr*))
+  (test-equal '(1 10 3 4 5) (set lst cadr* 10)))
 
 (test-group "Modify"
   (define lst '(1 2 3 4 5))
-  (test-equal '(10 2 3 4 5) (modify lst car* * 10))
-  (test-equal '(1 20 3 4 5) (modify lst cadr* * 10))
+  (test-equal '(10 2 3 4 5) (modify lst car*  (lambda (x) (* x 10))))
+  (test-equal '(1 20 3 4 5) (modify lst cadr* (lambda (x) (* x 10))))
   )
 
 (test-group "Modify*"
   (define lst '(1 2 3 4 5))
-  (test-equal '(1 2 4 4 5) (modify* lst cdr* cdr* car* 1+)))
-
-;; modify
-;; modify*
-;; set
-;; get
-
-;; identity-lens
-;; compose-lenses
-;; lens-compose
-
-;; ref car* cdr*
+  (test-equal '(1 2 4 4 5)
+    (modify lst (lens-compose cdr* cdr* car*) 1+)))
+
+(test-equal
+    "!e!l!,!W!r!d"
+  (list->string
+   (map cadr
+        (set (enumerate (string->list "Hello, World"))
+             (compose-lens
+              (focus-matching (compose even? car))
+              cdr*)
+             '(#\!)))))
+
+
+(test-group "Identity lens"
+  (test-equal 'anything
+    (get 'anything identity-lens))
+  (test-equal 'else
+    (set 'anything identity-lens 'else))
+
+  (test-equal '(1 x 3)
+    (set '(1 2 3) (lens-compose cdr* identity-lens car*)
+         'x)))
 
-;; each
 
 '((hnh util lens))
-- 
cgit v1.2.3