diff options
Diffstat (limited to '')
-rw-r--r-- | tests/test/datetime.scm | 40 | ||||
-rw-r--r-- | tests/test/lens.scm | 21 | ||||
-rw-r--r-- | tests/test/object.scm | 80 | ||||
-rw-r--r-- | tests/test/recurrence-advanced.scm | 1 |
4 files changed, 124 insertions, 18 deletions
diff --git a/tests/test/datetime.scm b/tests/test/datetime.scm index 2a5ac141..f73a0ad2 100644 --- a/tests/test/datetime.scm +++ b/tests/test/datetime.scm @@ -70,45 +70,44 @@ (test-error "Invalid second" 'wrong-type-arg (time second: #f)))) (test-group "Datetime" - (let ((get-time% (@@ (datetime) get-time%))) + (let () (test-group "Empty datetime" (let ((dt (datetime))) - ;; TODO figure out propper export of get-time% - (test-assert "Datetime date is date" (date? (get-date dt))) - (test-assert "Datetime date is zero" (date-zero? (get-date dt))) - (test-assert "Datetime time is time" (time? (get-time% dt))) - (test-assert "Datetime time is zero" (time-zero? (get-time% dt))) - (test-eqv "Defalut timezone is #f" #f (get-timezone dt)))) + (test-assert "Datetime date is date" (date? (datetime-date dt))) + (test-assert "Datetime date is zero" (date-zero? (datetime-date dt))) + (test-assert "Datetime time is time" (time? (datetime-time dt))) + (test-assert "Datetime time is zero" (time-zero? (datetime-time dt))) + (test-eqv "Defalut timezone is #f" #f (tz dt)))) (test-group "Datetime with keys" (let ((dt (datetime date: (date day: 10) time: (time minute: 20)))) (test-equal "Given date is stored" - 10 (day (get-date dt))) + 10 (day (datetime-date dt))) (test-equal "Given time is stored" - 20 (minute (get-time% dt)))) + 20 (minute (datetime-time dt)))) (test-error "Date must be a date" 'wrong-type-arg (datetime date: 1)) (test-error "Date must be a date" 'wrong-type-arg (datetime date: (time))) - (test-assert "Date: #f gives still constructs a date" (date? (get-date (datetime date: #f)))) + (test-assert "Date: #f gives still constructs a date" (date? (datetime-date (datetime date: #f)))) (test-error "Time must be a time" 'wrong-type-arg (datetime time: 1)) (test-error "Time must be a time" 'wrong-type-arg (datetime time: (date))) - (test-assert "Time: #f gives still constructs a time" (time? (get-time% (datetime time: #f)))) + (test-assert "Time: #f gives still constructs a time" (time? (datetime-time (datetime time: #f)))) (let ((dt (datetime hour: 20 day: 30))) - (test-equal "Time objects can be implicitly created" 20 (hour (get-time% dt))) - (test-equal "Date objects can be implicitly created" 30 (day (get-date dt)))) + (test-equal "Time objects can be implicitly created" 20 (hour (datetime-time dt))) + (test-equal "Date objects can be implicitly created" 30 (day (datetime-date dt)))) (let ((dt (datetime day: 30 time: (time hour: 20)))) (test-equal "\"Upper\" and \"lower\" keys can be mixed" - 20 (hour (get-time% dt))) + 20 (hour (datetime-time dt))) (test-equal "\"Upper\" and \"lower\" keys can be mixed" - 30 (day (get-date dt)))) + 30 (day (datetime-date dt)))) (let ((dt (datetime hour: 30 time: (time hour: 20)))) (test-equal "time: has priority over hour: (and the like)" - 20 (hour (get-time% dt))))) + 20 (hour (datetime-time dt))))) (let ((dt (datetime day: 30 date: (date day: 20)))) (test-equal "date: has priority over day: (and the like)" - 20 (day (get-date dt))))))) + 20 (day (datetime-date dt))))))) ;; Before the general parser, since it's a dependency string->datetime. (test-group "Parse Month" @@ -384,7 +383,7 @@ (test-assert "Current datetime returns a datetime" (datetime? (current-datetime))) (test-equal "Current datetime returns with tz: UTC" - "UTC" (get-timezone (current-datetime))) + "UTC" (tz (current-datetime))) (test-assert "Current-date returns a date" (date? (current-date))) @@ -707,6 +706,11 @@ date-range (not (datetime< (datetime day: 1) (datetime day: 2) (datetime day: 1))))))) ;; TODO +date<= +time<= +datetime<= + +;; TODO date/-time< date/-time<? date/-time<= date/-time<=? date/-time> date/-time>? date/-time>= date/-time>=? diff --git a/tests/test/lens.scm b/tests/test/lens.scm new file mode 100644 index 00000000..0797e3aa --- /dev/null +++ b/tests/test/lens.scm @@ -0,0 +1,21 @@ +(define-module (test lens) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :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)) + + +;; (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)) + +;; (set (list (iota 10)) first first 11) diff --git a/tests/test/object.scm b/tests/test/object.scm new file mode 100644 index 00000000..701c45c0 --- /dev/null +++ b/tests/test/object.scm @@ -0,0 +1,80 @@ +(define-module (test object) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (hnh util object) + :use-module ((hnh util) :select (->))) + +(define-type (f) x) + +(test-group "Created procedures" + (test-assert "Constructor" (procedure? f)) + (test-assert "Predicate" (procedure? f?)) + (test-assert "Field access" (procedure? x))) + +;; (f) +;; (f x: 10) +;; (f? (f)) + +(test-equal "Accessors are getters" + 10 (x (f x: 10))) +(test-assert "Accessors update, returning a object of the original type" + (f? (x (f x: 10) 20))) +(test-equal "A get after an update returns the new value" + 20 (-> (f x: 10) + (x 20) + x)) + + +(define-type (g) x) + +(test-assert "Second type can be created" + (g x: 10)) + +(test-assert "Second type isn't first type" + (not (f? (g x: 10)))) + +(test-assert "First type isn't second type" + (not (g? (f x: 10)))) + +;; Tests that the old x gets shadowed +;; (test-equal 10 (x (f x: 10))) +;; (test-equal 10 (x (g x: 10))) + +;; field-level arguments +;; - init: +(define-type (f2) (f2-x default: 0 type: integer?)) +(test-equal 0 (f2-x (f2))) + +;; - type: + +(test-error "Giving an invalid type to the constructor throws an error" + 'wrong-type-arg (f2 f2-x: 'hello)) +(test-error "Giving an invalid type to a setter throws an error" + 'wrong-type-arg (f2-x (f2) 'hello)) +(test-equal "The error includes the name of the field, the expected type, and the given value" + '(f2-x integer? hello) + (catch 'wrong-type-arg (lambda () (f2-x (f2) 'hello)) + (lambda (err proc fmt args data) args))) + +(test-equal "Typed setter updates the value" + (f2 f2-x: 10) (f2-x (f2) 10)) + +;; type-level arguments +;; - constructor: +(define-type (f3 constructor: (lambda (make check) + (lambda* (#:key f3-x f3-y) + (check f3-x f3-y) + (make f3-x f3-y)))) + (f3-x type: integer?) + (f3-y type: string?)) + +(test-assert "Custom constructors create objcets" + (f3? (f3 f3-x: 10 f3-y: "Hello"))) + +(test-error "Bad arguments to custom constructor" + 'wrong-type-arg (f3 f3-x: 'hello f3-y: 'world)) + +;; - printer: +(define-type (f4 printer: (lambda (r p) (display "something" p)))) +(test-equal "something" (with-output-to-string (lambda () (write (f4))))) diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm index a291cc17..56f4cda6 100644 --- a/tests/test/recurrence-advanced.scm +++ b/tests/test/recurrence-advanced.scm @@ -27,6 +27,7 @@ :use-module ((datetime) :select (parse-ics-datetime datetime + datetime-date time date datetime->string)) |