diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-24 21:11:16 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-24 21:11:16 +0200 |
commit | 987b1e0e574007b272b04605f3b57d420bde4fb4 (patch) | |
tree | 003c430e6a46cbcff09f60d9783f861506115de8 /module/hnh | |
parent | Add tests for href stuff. (diff) | |
parent | Document type and object system. (diff) | |
download | calp-987b1e0e574007b272b04605f3b57d420bde4fb4.tar.gz calp-987b1e0e574007b272b04605f3b57d420bde4fb4.tar.xz |
Merge remote-tracking branch 'origin/new-object-system' into datarewrite-structures
Diffstat (limited to '')
-rw-r--r-- | module/hnh/util/lens.scm | 99 | ||||
-rw-r--r-- | module/hnh/util/object.scm | 169 | ||||
-rw-r--r-- | module/hnh/util/type.scm | 46 |
3 files changed, 314 insertions, 0 deletions
diff --git a/module/hnh/util/lens.scm b/module/hnh/util/lens.scm new file mode 100644 index 00000000..7a8fbd19 --- /dev/null +++ b/module/hnh/util/lens.scm @@ -0,0 +1,99 @@ +(define-module (hnh util lens) + :use-module (srfi srfi-1) + :export (modify + modify* + set + get + + identity-lens + compose-lenses + lens-compose + + ref car* cdr*)) + + +(define (modify object lens f . args) + (lens object (apply f (lens object) args))) + +(define-syntax modify* + (syntax-rules () + ((_ object f) (f object)) + ((_ object lens rest ...) + (modify object lens + (lambda (object*) (modify* object* rest ...)))))) + +;; The simple case of getting and setting when you already have the lens is trivial +;; (lens object) +;; (lens object new-value) + +(define-syntax set + (syntax-rules () + ((_ object lenses ... value) + (modify* object lenses ... (const value))))) + +(define-syntax get + (syntax-rules () + ((_ object) object) + ((_ object f lenses ...) + (get (f object) lenses ...)))) + + + + +(define (make-lens getter setter) + (case-lambda ((datum) (getter datum)) + ((datum new-value) (setter datum new-value)))) + +(define-syntax build-lens + (syntax-rules () + ((_ (getter gargs ...) + (setter sargs ...)) + ;; (make-lens (lambda (datum) (getter datum gargs ...)) + ;; (lambda (datum new-value) (setter datum sargs ... new-value))) + (case-lambda ((datum) + (getter datum gargs ...)) + ((datum new-value) + (setter datum sargs ... new-value)))) + ((_ (getter args ...) setter) + (build-accesor (getter args ...) (setter))) + ((_ getter (setter args ...)) + (build-lens (getter) (setter args ...))) + ((_ getter setter) + (build-lens (getter) (setter))))) + + + + +(define identity-lens + (case-lambda ((a) a) + ((_ a) a))) + +(define (compose-lenses% f g) + (build-lens (get f g) (set f g))) + +(define (compose-lenses . fs) + (reduce-right compose-lenses% identity-lens fs)) + +(define lens-compose compose-lenses) + + + +(define (list-change list index value) + (cond ((zero? index) + (cons value (cdr list))) + ((null? list) + (scm-error 'out-of-range "list-change" "" #f #f)) + (else + (cons (car list) + (list-change (cdr list) + (1- index) + value))))) + + + +(define (ref idx) + (build-lens (list-ref idx) (list-change idx))) + + +(define car* (make-lens car (lambda (pair value) (cons value (cdr pair))))) +(define cdr* (make-lens cdr (lambda (pair value) (cons (car pair) value)))) diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm new file mode 100644 index 00000000..4477b462 --- /dev/null +++ b/module/hnh/util/object.scm @@ -0,0 +1,169 @@ +(define-module (hnh util object) + :use-module (srfi srfi-9 gnu) + :use-module (ice-9 curried-definitions) + :use-module (hnh util) + :use-module (hnh util type) + :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))) + + + +;; 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/module/hnh/util/type.scm b/module/hnh/util/type.scm new file mode 100644 index 00000000..800834e5 --- /dev/null +++ b/module/hnh/util/type.scm @@ -0,0 +1,46 @@ +(define-module (hnh util type) + :use-module ((srfi srfi-1) :select (every)) + :export (build-validator-body + list-of pair-of + typecheck + current-procedure-name)) + +(define-syntax list-of + (syntax-rules () + ((_ variable (rule ...)) + (and (list? variable) + (every (lambda (x) (build-validator-body x (rule ...))) variable))) + ((_ variable rule) + (and (list? variable) + (every rule variable))))) + +(define-syntax-rule (pair-of variable a b) + (and (pair? variable) + (build-validator-body (car variable) a) + (build-validator-body (cdr variable) b))) + +;; 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 list-of) + ((_ 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)))) + +(define-syntax-rule (current-procedure-name) + ;; 1 since make-stack is at top of stack + (frame-procedure-name (stack-ref (make-stack #t) 1))) + +(define-syntax typecheck + (syntax-rules () + ((_ variable type-clause) + (let ((procedure-name (current-procedure-name))) + (typecheck variable type-clause procedure-name))) + ((_ variable type-clause procedure-name) + (unless (build-validator-body variable type-clause) + (scm-error 'wrong-type-arg procedure-name + "Invalid value for ~s. Expected ~s, got ~s" + (list (quote variable) (quote type-clause) variable) + #f))))) + |