From c64a4bc56f93c08cf55fb907078e588ad737684c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 5 Sep 2023 00:55:35 +0200 Subject: Major work on, something. --- tests/test/add-and-save.scm | 123 ------------------------------------ tests/test/annoying-events.scm | 2 +- tests/test/create.scm | 14 +++-- tests/test/hnh-util-lens.scm | 38 +++++++++++ tests/test/param.scm | 33 +++++----- tests/test/recurrence-advanced.scm | 2 +- tests/test/vcomponent.scm | 125 ++++++++++++++++++++++++++----------- 7 files changed, 156 insertions(+), 181 deletions(-) delete mode 100644 tests/test/add-and-save.scm (limited to 'tests/test') 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) ))) - - -(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))) - stringstring)) + +(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? -- cgit v1.2.3