From 3205aa7566752d1b78ab452272c465ed0895b4e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 27 Jun 2022 14:59:44 +0200 Subject: Add new object system. fixup object tests. --- module/hnh/util/object.scm | 177 +++++++++++++++++++++++++++++++++++++++++++++ tests/test/object.scm | 80 ++++++++++++++++++++ 2 files changed, 257 insertions(+) create mode 100644 module/hnh/util/object.scm create mode 100644 tests/test/object.scm 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 ((? (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 being equal for similar types... + ;; See the manual 6.10.10 Hygiene and the Top-Level + (with-syntax (( (construct-syntax stx #'name "<~a>")) + (make- (construct-syntax stx #'name "make-~a%"))) + #`(begin + (define-immutable-record-type + (make- #,@(map syntax-first #'(field ...))) + ? + #,@(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 validator + (lambda #,(map syntax-first #'(field ...)) + (validator field) ...)))) + (else #`(lambda* (key: #,@(map lambda*-stx #'(field ...))) + ;; Type validators + (validator field) ... + (make- #,@(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! #,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))))) -- cgit v1.2.3