Major work on, something.

9 files changed, 182 insertions, 201 deletions

diff --git a/tests/formats/test.scm b/tests/formats/test.scm
index b4a00a73..dfa04f22 100755
--- a/tests/formats/test.scm
+++ b/tests/formats/test.scm
@@ -79,15 +79,15 @@ exec $GUILE -s "$0" "$@"
               (call-with-output-string
                 (lambda (p) (serialize component p)))))
 
-           (test-equal "Deserialized object serializes back into source"
-             (sanitize-string component-str)
-             (sanitize-string
-              (call-with-output-string
-                (lambda (p)
-                  (serialize
-                   (call-with-input-string
-                       component-str deserialize)
-                   p)))))
+           (test-group "Deserialize"
+             (let ((object (call-with-input-string component-str deserialize)))
+               (test-assert "Deserialize worked" (vcomponent? object))
+
+               (test-equal "Deserialized object serializes back into source"
+                 (sanitize-string component-str)
+                 (sanitize-string
+                  (call-with-output-string
+                    (lambda (p) (serialize object p)))))))
 
 
            (test-assert "Serialized string can still be read back in"
diff --git a/tests/run-tests.scm b/tests/run-tests.scm
index d3ba53f8..6c6ff95a 100755
--- a/tests/run-tests.scm
+++ b/tests/run-tests.scm
@@ -74,7 +74,8 @@ fi
   '((skip (value #t))
     (only (value #t))
     (verbose (single-char #\v))
-    (coverage (value optional))))
+    (coverage (value optional))
+    (catch)))
 
 (define options (getopt-long (command-line) option-spec))
 
@@ -112,17 +113,22 @@ fi
 
 ;;; Catch/print-trace should intercept thrown exceptions, print them prettily with a stack trace, and then continue
 
-#;
-(define (catch/print-trace proc)
-  (catch #t proc
-    (case-lambda
-      ((err from msg args data)
-       (test-assert (format #f "~a in ~a: ~?" err from msg args)
-         #f))
-      (args
-       (test-assert (format #f "~a (~s)" f args)
-         #f)))))
 
+
+(define catch/print-trace
+  (if (option-ref options 'catch #f)
+      (lambda (proc)
+        (catch #t proc
+          (case-lambda
+            ((err from msg args data)
+             (test-assert (format #f "~a in ~a: ~?" err from msg args)
+               #f))
+            (args
+             (test-assert (format #f "~a (~s)" f args)
+               #f)))))
+      (lambda (proc) (proc))))
+
+#;
 (define (catch/print-trace proc)
   (proc))
 
diff --git a/tests/test/add-and-save.scm b/tests/test/add-and-save.scm
deleted file mode 100644
index efbfe09e..00000000
--- a/tests/test/add-and-save.scm
+++ /dev/null
@@ -1,123 +0,0 @@
-(define-module (test add-and-save)
-  :use-module (srfi srfi-64)
-  :use-module (srfi srfi-88)
-  :use-module (hnh util)
-  :use-module (datetime)
-  :use-module (datetime timespec)
-  ;; :use-module ((vcomponent) :select (prop))
-  :use-module ((vcomponent base) :select (prop type children make-vcomponent))
-  :use-module ((srfi srfi-1) :select (find))
-  :use-module ((vcomponent formats vdir save-delete) :select (save-event))
-  :use-module ((vcomponent create)
-               :select (with-parameters
-                        vcalendar vevent
-                        vtimezone standard daylight))
-  :use-module (vcomponent recurrence)
-  :use-module ((vcomponent util instance methods)
-               :select (add-calendars
-                        add-and-save-event
-                        remove-event
-                        )))
-
-(define timezone
-  (vtimezone
-   tzid: "Europe/Stockholm"
-   (list
-    (standard
-     tzoffsetto: (parse-time-spec "01:00")
-     dtstart: #1996-10-27T01:00:00
-     tzname: "CET"
-     tzoffsetfrom: (parse-time-spec "02:00")
-     rrule: (make-recur-rule
-             freq: 'YEARLY
-             interval: 1
-             byday: (list (cons -1 sun))
-             bymonth: (list 10)
-             ))
-    (daylight
-     tzoffsetto: (parse-time-spec "02:00")
-     dtstart: #1981-03-29T01:00:00
-     tzname: "CEST"
-     tzoffsetfrom: (parse-time-spec "00:00")
-     rrule: (make-recur-rule
-             freq: 'YEARLY
-             interval: 1
-             byday: (list (cons -1 sun))
-             bymonth: (list 3))))))
-
-(define ev
-  (vevent
-   uid: "3da506ad-8d27-4810-94b3-6ab341baa1f2"
-   summary: "Test Event #1"
-   dtstart: (with-parameters
-             tzid: "Europe/Stockholm"
-             #2021-12-21T10:30:00)
-   dtstamp: #2021-12-21T14:10:56Z
-   dtend: (with-parameters
-           tzid: "Europe/Stockholm"
-           #2021-12-21T11:45:00)))
-
-(define rep-ev
-  (vevent
-   uid: "4ebd6632-d192-4bf4-a33a-7a8388185914"
-   summary: "Repeating Test Event #1"
-   rrule: (make-recur-rule freq: 'DAILY)
-   dtstart: (with-parameters
-             tzid: "Europe/Stockholm"
-             #2021-12-21T10:30:00)
-   dtstamp: #2021-12-21T14:10:56Z
-   dtend: (with-parameters
-           tzid: "Europe/Stockholm"
-           #2021-12-21T11:45:00)
-   ))
-
-(define directory (mkdtemp (string-copy"/tmp/guile-test-XXXXXX")))
-(format #t "Using ~a~%" directory)
-
-(define event-object ((@ (oop goops) make)
-                      (@@ (vcomponent util instance methods) <events>)))
-
-
-(define calendar
-  (vcalendar
-   #:-X-HNH-SOURCETYPE 'vdir
-   #:-X-HNH-DIRECTORY directory
-   ))
-
-(add-calendars event-object calendar)
-
-;; Try adding   and saving a  new      regular   event
-(add-and-save-event event-object calendar ev)
-
-;; Try changing and saving an existing regular   event
-(set! (prop ev 'SUMMARY) "Changed summary")
-(add-and-save-event event-object calendar ev)
-
-;; Try adding   and saving a  new      repeating event
-(add-and-save-event event-object calendar rep-ev)
-
-;; Try changing and saving an existing repeating event
-;; TODO setting start time to later than end time leads to nonsense
-;; errors when trying to generate the recurrence set.
-(set! (prop rep-ev 'DTSTART) (datetime+ (prop rep-ev 'DTSTART)
-                                        (datetime time: (time hour: 1))))
-(add-and-save-event event-object calendar rep-ev)
-
-;; Try adding   and saving a  new                event with multiple instances
-;; Try changing and saving an existing           event with multiple instances
-
-;; (add-and-save-event event-object calendar event)
-
-
-(test-equal "Correct amount of children in calendar"
-  5 (length (children calendar)))
-
-
-(define get-events (@@ (vcomponent util instance methods) get-events))
-(test-equal "Event object contains correct number of events (single calendar)"
-  2 (length (get-events event-object)))
-
-(remove-event event-object (car (get-events event-object)))
-
-(test-equal "Correct number of events after removing first element"
-  1 (length (get-events event-object)))
diff --git a/tests/test/annoying-events.scm b/tests/test/annoying-events.scm
index d41ee450..a6f5e946 100644
--- a/tests/test/annoying-events.scm
+++ b/tests/test/annoying-events.scm
@@ -9,7 +9,7 @@
              stream-filter
              stream-take-while))
   :use-module ((vcomponent base)
-   :select (extract prop make-vcomponent))
+   :select (extract prop))
   :use-module ((vcomponent datetime) :select (event-overlaps?))
   :use-module ((datetime) :select (date date+ date<))
   :use-module ((hnh util) :select (set!))
diff --git a/tests/test/create.scm b/tests/test/create.scm
index ca055df1..7cc00419 100644
--- a/tests/test/create.scm
+++ b/tests/test/create.scm
@@ -2,8 +2,12 @@
   :use-module ((srfi srfi-1) :select (every))
   :use-module (srfi srfi-64)
   :use-module (srfi srfi-88)
-  :use-module (vcomponent create)
-  :use-module (vcomponent))
+  :use-module ((vcomponent create)
+               :select (vcomponent
+                        with-parameters
+                        as-list))
+  :use-module ((vcomponent)
+               :select (children properties type prop prop* param vline?)))
 
 ;; vevent, vcalendar, vtimezone, standard, and daylight all trivial
 ;; and therefore not tested
@@ -26,7 +30,8 @@
                         (list child))))
     (test-equal '() (properties ev))
     (test-equal 1 (length (children ev)))
-    (test-eq child (car (children ev)))))
+    ; (test-eq child (car (children ev)))
+    ))
 
 (test-group "Component with both children and properties"
   (let* ((child (vcomponent 'CHILD))
@@ -36,7 +41,8 @@
     (test-equal '(PROP) (map car (properties ev)))
     (test-equal "VALUE" (prop ev 'PROP))
     (test-equal 1 (length (children ev)))
-    (test-eq child (car (children ev)))))
+    ; (test-eq child (car (children ev)))
+    ))
 
 (test-group "Component with no children, where last elements value is a list"
   (let ((ev (vcomponent 'TEST prop: (list 1 2 3))))
diff --git a/tests/test/hnh-util-lens.scm b/tests/test/hnh-util-lens.scm
index bcfafba2..0508553a 100644
--- a/tests/test/hnh-util-lens.scm
+++ b/tests/test/hnh-util-lens.scm
@@ -19,3 +19,41 @@
 (test-equal '(1 (10) 3) (set '(1 (2) 3) (ref 1) (ref 0) 10))
 
 ;; (set (list (iota 10)) first first 11)
+
+(define cadr* (compose-lenses 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 '(10 2 3 4 5)
+    (car* lst 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-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-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*
+
+;; each
diff --git a/tests/test/param.scm b/tests/test/param.scm
index 34f7b826..431a8f46 100644
--- a/tests/test/param.scm
+++ b/tests/test/param.scm
@@ -8,10 +8,10 @@
   :use-module (srfi srfi-64 test-error)
   :use-module (srfi srfi-88)
   :use-module ((vcomponent base)
-               :select (param prop* parameters prop))
+               :select (param prop* parameters prop vline?))
   :use-module ((vcomponent formats ical parse)
                :select (parse-calendar))
-  :use-module ((vcomponent) :select (make-vcomponent))
+  :use-module ((vcomponent) :select (vcomponent properties set-properties))
   :use-module ((hnh util) :select (sort* set!))
   :use-module ((ice-9 ports) :select (call-with-input-string))
   :use-module ((vcomponent formats xcal output)
@@ -23,11 +23,12 @@
 ;; TODO possibly change parsing
 
 (define v
-  (call-with-input-string
-    "BEGIN:DUMMY
+  (car
+   (call-with-input-string
+       "BEGIN:DUMMY
 X-KEY;A=1;B=2:Some text
 END:DUMMY"
-    parse-calendar))
+     parse-calendar)))
 
 (test-equal '("1") (param (prop* v 'X-KEY) 'A))
 
@@ -35,17 +36,20 @@ END:DUMMY"
 
 (test-equal #f (param (prop* v 'X-KEY) 'C))
 
-(test-equal
-  '(A B)
-  (sort* (map car (parameters (prop* v 'X-KEY)))
-         string<?
-         symbol->string))
+
+(test-group "Properties"
+ (let ((p (properties v)))
+   (test-assert (list? p))
+   (test-eqv 1 (length p))
+   (test-eq 'X-KEY (caar p))
+   (test-assert (vline? (cadar p)))))
+
 
 
 ;; TODO possibly move this.
 ;; Checks that a warning is properly raised for
 ;; unkonwn keys (without an X-prefix)
-(test-error
+(test-error "Ensure parse-calendar warns on unknown keys"
   'warning
   (call-with-input-string
     "BEGIN:DUMMY
@@ -54,10 +58,9 @@ END:DUMMY"
     parse-calendar))
 
 ;; Similar thing happens for sxcal, but during serialization instead
-(let ((component (make-vcomponent 'DUMMY)))
-  (set! (prop component 'KEY) "Anything")
+(let ((component (set-properties (vcomponent type: 'DUMMY)
+                                 (cons 'KEY "Anything"))))
+
   (test-error
     'warning
     (vcomponent->sxcal component)))
-
-
diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm
index c4684ba7..c2d71e61 100644
--- a/tests/test/recurrence-advanced.scm
+++ b/tests/test/recurrence-advanced.scm
@@ -23,7 +23,7 @@
   :use-module ((vcomponent recurrence internal)
                :select (count until))
   :use-module ((vcomponent base)
-               :select (make-vcomponent prop prop* extract make-vline))
+               :select (prop prop* extract))
   :use-module (vcomponent create)
   :use-module ((datetime)
                :select (parse-ics-datetime
diff --git a/tests/test/vcomponent.scm b/tests/test/vcomponent.scm
index a6989776..bdaefa95 100644
--- a/tests/test/vcomponent.scm
+++ b/tests/test/vcomponent.scm
@@ -1,52 +1,103 @@
 ;;; Commentary:
-;; Test that vcomponent parsing works at all.
+;; Test base functionallity of vcomponent structures.
 ;;; Code:
 
 (define-module (test vcomponent)
   :use-module (srfi srfi-17)
   :use-module (srfi srfi-64)
   :use-module (srfi srfi-88)
-  :use-module ((vcomponent base)
-               :select (prop make-vcomponent reparent! abandon!
-                             copy-vcomponent
-                             type parent children)))
+  :use-module (hnh util table)
+  :use-module (datetime)
+  :use-module (vcomponent base))
+
+
+
 
 (define ev
-  (let ((ev (make-vcomponent 'DUMMY)))
-    (set! (prop ev 'X-KEY) "value")
-    ev))
+  (prop (vcomponent type: 'DUMMY)
+        'X-KEY "value"))
 
-(test-assert (eq? #f (prop ev 'MISSING)))
+(test-eqv "Non-existant properties return #f"
+  #f (prop ev 'MISSING))
 
-(test-assert (prop ev 'X-KEY))
+(test-assert "Existing property is non-false"
+  (prop ev 'X-KEY))
 
-(test-equal "value" (prop ev 'X-KEY))
+(test-equal "Getting value of existing property"
+  "value" (prop ev 'X-KEY))
 
-(define calendar (make-vcomponent 'VCALENDAR))
+(define calendar (add-child (vcomponent type: 'VCALENDAR)
+                            ev))
 
-(reparent! calendar ev)
 (test-equal 1 (length (children calendar)))
-(abandon! calendar ev)
-(test-equal 0 (length (children calendar)))
-
-
-(test-group "Copy VComponent"
-  (let ((ev1 (make-vcomponent 'A))
-        (ev2 (make-vcomponent 'B))
-        (ev3 (make-vcomponent 'C)))
-    (set! (prop ev3 'TEST) (list 1 2 3))
-    (reparent! ev1 ev2)
-    (reparent! ev2 ev3)
-    (let* ((ev2* (copy-vcomponent ev2))
-           (ev3* (car (children ev2*))))
-      ;; NOTE replace this with `vcomponent=?' if that gets written
-      (test-group "New object is equivalent to old one"
-        (test-equal (type ev2) (type ev2*))
-        (test-equal (length (children ev2)) (length (children ev2*))))
-      (test-eq ev1 (parent ev2))
-
-      (set! (car (prop ev3* 'TEST)) 10)
-      (test-equal "Property values aren't deep copied"
-        '(10 2 3) (prop ev3 'TEST))
-      (test-equal '(10 2 3) (prop ev3* 'TEST))
-      )))
+
+;;; TODO remove child
+;; (abandon! calendar ev)
+;; (test-equal 0 (length (children calendar)))
+
+
+
+(define vline*
+  (vline
+   key: 'DTSTART
+   vline-value: #2020-01-02
+   vline-parameters: (alist->table
+                      '((VALUE . "DATE")))
+   vline-source: "DTSTART;VALUE=DATE:2020-01-02"))
+
+(test-group "vline"
+ (test-assert "Type check works as expected"
+   (vline? vline*)))
+
+(define vcomponent*
+  (vcomponent type: 'VEVENT))
+
+(test-assert "Type check works as expected"
+  (vcomponent? vcomponent*))
+
+(define child
+  (vcomponent type: 'CHILD))
+
+
+(test-eqv
+    "An added component extends length"
+  1 (length (children (add-child vcomponent* child))))
+
+(test-eqv
+    "But the source isn't modified"
+  0 (length (children vcomponent*)))
+
+(test-equal "Setting property"
+  (list (list 'KEY (vline key: 'KEY vline-value: "Value")))
+  (properties
+   (prop vcomponent* 'KEY "Value")))
+
+(let ((vl (vline key: 'KEY vline-value: "Value")))
+  (test-equal "Setting property vline"
+    (list (list 'KEY vl))
+    (properties
+     (prop* vcomponent* 'KEY vl))))
+
+(test-equal "Set properties test"
+  '(K1 K2)
+  (map car
+   (properties
+    (apply set-properties
+           vcomponent*
+           `((K1 . "V1")
+             (K2 . "V2"))))))
+
+;; remove-property
+
+;; extract extract*
+
+
+;; remove-parameter
+;; value
+;; param
+
+;; parameters
+;; properties
+
+;; x-property?
+;; internal-field?