Add new object system.

fixup object tests.

2 files changed, 257 insertions, 0 deletions

diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
new file mode 100644
index 00000000..1ecacf8e
--- /dev/null
+++ b/module/hnh/util/object.scm
@@ -0,0 +1,177 @@
+(define-module (hnh util object)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-9 gnu)
+  :use-module (ice-9 curried-definitions)
+  :use-module (hnh util)
+  :export (define-type))
+
+;; If given a syntax list extract the first lexeme, if given a "symbol", return that.
+(define (syntax-first stx)
+  (syntax-case stx ()
+    ((a rest ...) #'a)
+    (a #'a)))
+
+(define (construct-syntax stx base transform)
+  (->> base
+       syntax->datum
+       (format #f transform)
+       string->symbol
+       (datum->syntax stx)))
+
+;; stx should be a syntax object of a key-value list on the form
+;; (key: value key2: value2)
+;; and target-key the datum which the target key unwraps to.
+;; returns the corresponding values syntax
+;; or #f if none is found
+(define (kv-ref stx target-key)
+  (syntax-case stx ()
+    ((key value rest ...)
+     (if (eqv? target-key (syntax->datum #'key))
+         #'value
+         (kv-ref #'(rest ...) target-key)))
+    (_ #f)))
+
+
+
+;; DSL for specifying type predicates
+;; Basically a procedure body, but the variable to test is implicit.
+(define-syntax build-validator-body
+  (syntax-rules (and or)
+    ((_ variable (and clauses ...))  (and (build-validator-body variable clauses) ...))
+    ((_ variable (or clauses ...))   (or (build-validator-body variable clauses) ...))
+    ((_ variable (proc args ...))    (proc variable args ...))
+    ((_ variable proc)               (proc variable))))
+
+
+;; Given (x type: predicate?), expand to a single `unless' form (otherwise #f)
+(define-syntax (validator stx)
+  (syntax-case stx ()
+    ((_ (name kvs ...))
+     (cond ((kv-ref #'(kvs ...) type:)
+            => (lambda (type-stx)
+                 (with-syntax ((type type-stx))
+                   #'(unless (build-validator-body name type)
+                       (scm-error 'wrong-type-arg "validator"
+                                  "Invalid value for `~s'. Expected ~s, got ~s"
+                                  (list (quote name) (quote type) name) #f)))))
+           (else #f)))
+    ((_ name) #f)))
+
+
+
+
+;; Get syntax for getter-procedure's symbol
+(define-syntax (field-get stx)
+  (syntax-case stx ()
+    ;; ((_ (name kv ...)) #'(field-get name))
+    ((_ type-name name)
+     (->>
+      (format #f "~a-~a-get"
+              (syntax->datum #'type-name)
+              (syntax->datum #'name))
+      string->symbol
+      (datum->syntax stx)))))
+
+;; get syntax for setter-procedure's symbol
+(define-syntax (field-set stx)
+  (syntax-case stx ()
+    ;; ((_ (name kv ...)) #'(field-set name))
+    ((_ type-name name)
+     (->>
+      (format #f "~a-~a-set"
+              (syntax->datum #'type-name)
+              (syntax->datum #'name))
+      string->symbol
+      (datum->syntax stx)))))
+
+;; Construct a field line for define-immutable-record-type
+(define ((field-declaration type) stx)
+  (syntax-case stx ()
+    (name
+     (with-syntax ((name-get (->> (format #f "~a-~a-get"
+                                          (syntax->datum type)
+                                          (syntax->datum #'name))
+                                  string->symbol
+                                  (datum->syntax stx)))
+                   (name-set (->> (format #f "~a-~a-set"
+                                          (syntax->datum type)
+                                          (syntax->datum #'name))
+                                  string->symbol
+                                  (datum->syntax stx))))
+       #'(name name-get name-set)))))
+
+;; Accessors are procedures for getting and setting fields in records
+(define-syntax (build-accessor stx)
+  (syntax-case stx ()
+    ((_ type-name (name kvs ...))
+     #'(define name
+         (case-lambda ((datum)
+                       ((field-get type-name name) datum))
+                      ((datum new-value)
+                       ;; validator uses the first field (in the list) as both
+                       ;; the name of the field, and a reference to the value of
+                       ;; the field. This ensures those two are the same for validator,
+                       ;; while keeping name bound to the accessor in the outer scope.
+                       (let ((name new-value))
+                         (validator (name kvs ...)))
+                       ((field-set type-name name) datum new-value)))))
+    ((_ type-name name) #'(build-accessor type-name (name)))))
+
+
+;; Go from my concept of field deffinitions, to what lambda* wants as arguments
+(define (lambda*-stx field)
+  (syntax-case field ()
+    ((name kvs ...)
+     (cond ((kv-ref #'(kvs ...) default:)
+            => (lambda (dflt) #`(name #,dflt)))
+           (else #'name)))
+    (name #'name)))
+
+
+
+(define-syntax (define-type stx)
+  (syntax-case stx ()
+    ((_ (name attribute ...) field ...)
+     ;; These names SHOULD leak
+     (with-syntax ((<type>? (construct-syntax stx #'name "~a?")))
+       ;; These names are manually constructed, since generated identifiers are
+       ;; only dependant on the source from which they orginate, which leads to
+       ;; multiple instances of <type> being equal for similar types...
+       ;; See the manual 6.10.10 Hygiene and the Top-Level
+       (with-syntax ((<type>      (construct-syntax stx #'name "<~a>"))
+                     (make-<type> (construct-syntax stx #'name "make-~a%")))
+         #`(begin
+             (define-immutable-record-type <type>
+               (make-<type> #,@(map syntax-first #'(field ...)))
+               <type>?
+               #,@(map (field-declaration #'name)
+                       (map syntax-first #'(field ...))))
+
+             ;; User-facing constructor
+             (define name
+               #,(cond ((kv-ref #'(attribute ...) constructor:)
+                        => (lambda (constructor-builder)
+                             #`(#,constructor-builder
+                                ;; primitive constructor
+                                make-<type>
+                                ;; Type validator
+                                (lambda #,(map syntax-first #'(field ...))
+                                  (validator field) ...))))
+                       (else #`(lambda* (key: #,@(map lambda*-stx #'(field ...)))
+                                 ;; Type validators
+                                 (validator field) ...
+                                 (make-<type> #,@(map syntax-first #'(field ...)))))))
+
+             ;; Field accessors
+             (build-accessor name field) ...
+
+             ;; if printer in attribute
+             #,@(cond ((kv-ref #'(attribute ...) printer:)
+                       => (lambda (printer)
+                            (list #`(set-record-type-printer! <type> #,printer))))
+                      (else '()))))))
+
+    ;; else, type name without extra attributes
+    #;
+    ((_ name field ...)
+     #'(define-type (name) field ...))))
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)))))