Complete rewrite of define-record-type.

dns/internal/object.scm

@@ -36,68 +36,105 @@
                     (list key (serialize value)))
                   this))
 
-;; Helper procedure for define-record-type macro, which if @var{stx} is a syntax
-;; object of a list takes the first argument of it, keeping it a syntax object
-(define (unlist stx)
-  (if (list? (syntax->datum stx))
-      (->> stx syntax->datum car (datum->syntax stx))
-      stx))
-
-(define (mlist->define-field stx)
-  (define l (syntax->datum stx))
-  (cond ((and (list? l)
-              (memv default: l))
-         => (lambda (field)
-              #`(#,(datum->syntax stx (car l))
-                 #,(datum->syntax stx (cadr field)))))
-        ((list? l)
-         (datum->syntax stx (car l)))
-        (else stx)))
+
+
+
+(define (handle-define*-clause stx)
+  (syntax-case stx ()
+    ((name default: default args ...) #'(name default))
+    ((name arg args ...) (handle-define*-clause #'(name args ...)))
+    ((name) #'name)
+    (name   #'name)))
+
+(define-syntax build-validator
+  (syntax-rules (and or)
+    ((_ variable (and clauses ...))  (and (build-validator variable clauses) ...))
+    ((_ variable (or clauses ...))   (or (build-validator variable clauses) ...))
+    ((_ variable (proc args ...))    (proc variable args ...))
+    ((_ variable proc)               (proc variable))))
+
+;; Given #'(<field-name> type: <validator-body>), expands validator-body to contain <field-name>
+;; string x field-spec → <validator syntax>
+(define (handle-validator constructor-name)
+  (define (inner field)
+    (syntax-case field ()
+      ((name type: validator-body args ...)
+       #`(unless (build-validator name validator-body)
+           (scm-error 'wrong-type-arg #,constructor-name
+                      "`~a: ~s' doesn't satisfy `~a'"
+                      (list (quote name) name (quote validator-body))
+                      (list (quote name) name))))
+      ((name arg args ...)
+       (inner #'(name args ...)))
+      ;; Case when no #:type annotation exists.
+      ;; Should hopefully be optimized away by the compiler
+      (_ #'(if #f #f))))
+  inner)
+
+
+;; Takes a field from the define-record-type macro, and returns the field name.
+;; E.g.
+;; (x args ...) ⇒ x
+;; x ⇒ x
+(define (field-name stx)
+  (syntax-case stx ()
+    ((name args ...) #'name)
+    (name #'name)))
+
+;; Helper function to use with with-syntax
+(define (binding pattern fmt)
+  (->> pattern
+       syntax->datum
+       (format #f fmt)
+       string->symbol
+       (datum->syntax pattern)))
 
 (define-syntax define-record-type
   (lambda (stx)
     (syntax-case stx (fields)
-      ((_ name (fields field ...))
-       (with-syntax ((make-name (->> #'name syntax->datum (format #f "make-~a")
-                                     string->symbol (datum->syntax stx)))
-                     (name-predicate (->> #'name syntax->datum (format #f "~a?")
-                                          string->symbol (datum->syntax stx))))
+      ((_ type (fields field ...))
+       (with-syntax ((make-<type> (binding #'type "make-~a"))
+                     (<type>?     (binding #'type "~a?")))
          #`(begin
-             ;; point
-             (define-class name ()
-               #,@(map (lambda (field-name)
-                         (cond ((list? (syntax->datum field-name))
-                                #`(#,(datum->syntax field-name (car (syntax->datum field-name)))
-                                   init-keyword: #,(-> field-name syntax->datum car symbol->keyword)
-                                   init-value: #,(cond ((memv default: (syntax->datum field-name))
-                                                        => (lambda (x)
-                                                             (datum->syntax field-name (cadr x))))
-                                                       (else #f))))
-                               (else
-                                #`(#,field-name
-                                   init-keyword: #,(-> field-name syntax->datum symbol->keyword)
-                                          ))))
-                       #'(field ...)))
-             ;; point?
-             (define (name-predicate object)
-               (is-a? object name))
-             ;; make-point
-             (define* (make-name key: #,@(map mlist->define-field #'(field ...)))
-               (make name
-                 #,@(apply append
-                           (map (lambda (name)
-                                  #`(#,(-> name syntax->datum symbol->keyword) #,name))
-                                (map unlist #'(field ...))))))
-             #,@(map (lambda (name)
-                       #`(define-method (#,name this)
-                           (slot-ref this (quote #,name))))
-                     (map unlist #'(field ...)))
-             (define-method (serialize (this name))
-               `(#,@(map (lambda (name)
-                           #`(#,name ,(#,name this)))
-                         (map unlist #'(field ...)))))
-             (define-method (write (this name) port)
+             ;; construct class
+             (define-class type ()
+               ;; needs a pre-expansion since define-class is a macro in itself
+               #,@(map field-name #'(field ...)))
+
+             ;; construct predicate
+             (define (<type>? x)
+               (is-a? x type))
+
+             ;; construct public-facing constructor
+             (define* (make-<type> key: #,@(map handle-define*-clause #'(field ...)))
+               #,@(map (handle-validator (symbol->string (syntax->datum #'make-<type>)))
+                       #'(field ...))
+
+               ;; bind all values to object
+               (let ((return-value (make type)))
+                 #,@(map (lambda (g)
+                           (with-syntax ((f (field-name g)))
+                             #`(slot-set! return-value (quote #,(field-name g)) f)))
+                         #'(field ...))
+                 return-value))
+
+             ;; accessors
+             #,@(map (lambda (g)
+                       ;; Supplying the symbol instead of the identifier works here,
+                       ;; due to how goops' define-method works.
+                       #`(define-method (#,(field-name g) (this type))
+                           (slot-ref this (quote #,(field-name g)))))
+                     #'(field ...))
+
+             ;; pretty printing
+             (define-method (serialize (this type))
+               (quasiquote
+                #,(map (lambda (g)
+                         (with-syntax ((f (field-name g)))
+                           #`(#,(field-name g) ,(serialize (f this)))))
+                       #'(field ...))))
+
+             (define-method (write (this type) port)
                ((@ (ice-9 format) format) port "#<~a~:{ ~a=~s~}>"
-                (class-name name)
-                (serialize this)))
-             ))))))
+                (class-name type)
+                (serialize this)))))))))

tests/object.scm

@@ -34,3 +34,11 @@
 ;; This is however explicitly specified
 (test-equal "Test default value for non-defaulted file with other kv-data"
   #f (x (make-r4)))
+
+
+
+
+(catch 'wrong-type-arg
+  (lambda () (make-r4 x: "Hello")
+     (test-assert "Type test didn't work" #f))
+  (lambda _ (test-assert "Type test failed correctly" #t)))