Merge branch 'new-object-system' into c-parser

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))