diff options
Diffstat (limited to 'src/guile/de-paul-records.scm')
| -rw-r--r-- | src/guile/de-paul-records.scm | 351 |
1 files changed, 351 insertions, 0 deletions
diff --git a/src/guile/de-paul-records.scm b/src/guile/de-paul-records.scm new file mode 100644 index 0000000..57d65e5 --- /dev/null +++ b/src/guile/de-paul-records.scm @@ -0,0 +1,351 @@ +;;; SPDX-License-Identifier: CC0-1.0 +;;; +;;; Copyright (C) 2023 Wojtek Kosior <koszko@koszko.org> + +(define-module (de-paul-records) + #:use-module ((srfi srfi-1) #:select (append-map)) + #:use-module ((srfi srfi-9 gnu) + #:select (define-immutable-record-type set-field set-fields)) + #:use-module ((srfi srfi-26) #:select (cut)) + #:use-module ((ice-9 format) #:select (format)) + #:use-module ((ice-9 match) #:select (match match-lambda)) + #:use-module ((ice-9 match) #:prefix ice-9-match:) + #:re-export (set-field set-fields) + #:export ((match-override . match) + (match-lambda-override . match-lambda) + (match-lambda*-override . match-lambda*) + (match-let-override . match-let) + (match-let*-override . match-let*) + (match-letrec-override . match-letrec) + + define-immutable-record-type*)) + +(eval-when (compile load eval) + (define (get-first-identifier list-of-identifiers-and-other) + (let loop ((items list-of-identifiers-and-other)) + (match items + (() + (throw 'programming-error)) + (((? identifier? item) . _) + item) + ((_ . rest) + (loop rest))))) + + (define* (format-identifiers fmt #:rest args) + (let* ((first-identifier (get-first-identifier args)) + (processed-args (map (match-lambda + ((? identifier? identifier) + (symbol->string (syntax->datum identifier))) + (other + other)) + args)) + (formatted-string (apply format #f fmt processed-args))) + (datum->syntax first-identifier (string->symbol formatted-string)))) + + (define-immutable-record-type <field-spec> (make-field-spec) field-spec? + (name field-spec-name field-spec-set-name) + (default field-spec-default field-spec-set-default)) + + (define %null-field-spec + (set-field (make-field-spec) + (field-spec-default) #'#f)) + + (define (syntax->field-spec x) + (syntax-case x () + (field-name + (identifier? #'field-name) + (syntax->field-spec #'(field-name))) + ((field-name . field-args) + (let loop ((field-spec %null-field-spec) + (args #'field-args)) + (syntax-case args () + (() + (field-spec-set-name field-spec #'field-name)) + ((#:default default . args-rest) + (eq? (field-spec-default field-spec) + (field-spec-default %null-field-spec)) + (loop (field-spec-set-default field-spec #'default) + #'args-rest))))))) + + (define-immutable-record-type <record-spec> (make-record-spec) record-spec? + (name record-spec-name record-spec-set-name) + (fields record-spec-fields record-spec-set-fields) + (export? record-spec-export? record-spec-set-export?) + (finalize record-spec-finalize record-spec-set-finalize)) + + (define %null-record-spec + (set-fields (make-record-spec) + ((record-spec-fields) '()) + ((record-spec-export?) 'false-by-default))) + + (define (syntax->record-spec x) + (syntax-case x () + ((_ record-name . record-args) + (identifier? #'record-name) + (let loop ((record-spec %null-record-spec) + (args #'record-args)) + (syntax-case args () + (() + (set-fields record-spec + ((record-spec-name) #'record-name) + ((record-spec-fields) (reverse (record-spec-fields + record-spec))))) + ((#:export? export? . args-rest) + (eq? (record-spec-export? record-spec) 'false-by-default) + (loop (record-spec-set-export? record-spec + (and (syntax->datum #'export?) #t)) + #'args-rest)) + ((#:finalize finalizer . args-rest) + (not (record-spec-finalize record-spec)) + (loop (record-spec-set-finalize record-spec + #'finalizer) + #'args-rest)) + ((field-def . args-rest) + (loop (record-spec-set-fields record-spec + (cons (syntax->field-spec #'field-def) + (record-spec-fields record-spec))) + #'args-rest))))))) + + (define-immutable-record-type <field-init> (make-field-init) field-init? + (name field-init-name field-init-set-name) + (value-expr field-init-value-expr field-init-set-value-expr)) + + (define %null-field-init + (make-field-init)) + + (define (syntax->field-init x) + (syntax-case x () + ((field-name value-expr) + (identifier? #'field-name) + (set-fields %null-field-init + ((field-init-name) #'field-name) + ((field-init-value-expr) #'value-expr))) + (field-name + (identifier? #'field-name) + (syntax->field-init #'(field-name field-name))))) + + (define-immutable-record-type <record-init> (make-record-init) record-init? + (inherit record-init-inherit record-init-set-inherit) + (fields record-init-fields record-init-set-fields)) + + (define %null-record-init + (set-fields (make-record-init) + ((record-init-inherit) #f) + ((record-init-fields) '()))) + + (define (syntax->record-init x) + (syntax-case x () + ((_ . init-args) + (let loop ((record-init %null-record-init) + (args #'init-args)) + (syntax-case args () + (() + (set-field record-init + (record-init-fields) (reverse (record-init-fields record-init)))) + ((#:<- base . args-rest) + (not (record-init-inherit record-init)) + (loop (record-init-set-inherit record-init #'base) + #'args-rest)) + ((field-init . args-rest) + (loop (record-init-set-fields record-init + (cons (syntax->field-init #'field-init) + (record-init-fields record-init))) + #'args-rest))))))) + + (define (transform-record-init record-name %null-record init-form) + (match init-form + ((= syntax->record-init (and (= record-init-inherit inherit) + (= record-init-fields field-inits))) + #`(let* (#,@(map (match-lambda + ((and (= field-init-name field-name) + (= field-init-value-expr value-expr)) + #`(#,field-name #,value-expr))) + field-inits)) + (set-fields #,(or inherit %null-record) + #,@(map (match-lambda + ((= field-init-name field-name) + #`((#,(format-identifiers "~a-~a" + record-name field-name)) + #,field-name))) + field-inits)))))) + + (define-syntax define-immutable-record-type* + (match-lambda + ((= syntax->record-spec (and my-record-spec + (= record-spec-name record-name) + (= record-spec-fields field-specs) + (= record-spec-export? export?) + (= record-spec-finalize finalize))) + (with-syntax ((<record> (format-identifiers "<~a>" record-name)) + (--make-record (format-identifiers "--make-~a" + record-name)) + (record? (format-identifiers "~a?" record-name)) + (%null-record (format-identifiers "%null-~a" record-name)) + (*record (format-identifiers "*~a" record-name)) + (--finalize-record (format-identifiers "--finalize-~a" + record-name))) + #`(begin + (define-immutable-record-type <record> (--make-record) record? + #,@(map (match-lambda + ((= field-spec-name field-name) + #`(#,field-name + #,@(map (cut format-identifiers <> + record-name field-name) + '("~a-~a" "~a-set-~a"))))) + field-specs)) + + (define %null-record + (set-fields (--make-record) + #,@(map (match-lambda + ((and (= field-spec-name field-name) + (= field-spec-default default)) + #`((#,(format-identifiers "~a-~a" + record-name field-name)) + #,default))) + field-specs))) + + (define-syntax *record + (cut transform-record-init #'#,record-name #'%null-record <>)) + + (define --finalize-record + #,(or finalize #'identity)) + + (define-syntax-rule (#,record-name . body-rest) + (--finalize-record (*record . body-rest))) + + #,@(if (eq? export? #t) + (list + #`(export <record> #,record-name record? %null-record + #,@(append-map + (match-lambda + ((= field-spec-name field-name) + (map (cut format-identifiers <> + record-name field-name) + '("~a-~a" "~a-set-~a")))) + field-specs))) + #'())))))) + + (define (map-syntax proc syntax-list) + (syntax-case syntax-list () + (() + '()) + ((item . rest) + (cons (proc #'item) (map-syntax proc #'rest))))) + + (define (transform-match-field record-name-base field-form) + (syntax-case field-form () + (field-name + (identifier? #'field-name) + (transform-match-field record-name-base #'(field-name field-name))) + ((field-name pat pats ...) + (identifier? #'field-name) + (with-syntax ((record-field (format-identifiers "~a-~a" + record-name-base #'field-name))) + #`(= record-field + (and #,@(map-syntax transform-match-pat #'(pat pats ...)))))))) + + (define (transform-match-pat pat-form) + (syntax-case pat-form ($* = ? quote quasiquote) + ((quote something) + #'(quote something)) + ((quasiquote something) + #`(quasiquote #,(transform-quasiquoted-match-pat #'something))) + (#(pats ...) + (with-syntax (((pats* ...) #`(#,@(map-syntax transform-match-pat + #'(pats ...))))) + #'#(pats* ...))) + (($* record-name-base pats ...) + (identifier? #'record-name-base) + (with-syntax ((record? (format-identifiers "~a?" #'record-name-base))) + #`(? record? #,@(map-syntax (cut transform-match-field + #'record-name-base <>) + #'(pats ...))))) + ((= field pat) + #`(= field #,(transform-match-pat #'pat))) + ((? pred pats ...) + #`(? pred #,@(map-syntax transform-match-pat #'(pats ...)))) + ((head . tail) + #`(#,(transform-match-pat #'head) . #,(transform-match-pat #'tail))) + (other + #'other))) + + (define (transform-quasiquoted-match-pat pat-form) + (syntax-case pat-form (unquote unquote-splicing) + ((unquote something) + #`(unquote #,(transform-match-pat #'something))) + ((unquote-splicing something) + #`(unquote-splicing #,(transform-match-pat #'something))) + ((head . tail) + #`(#,(transform-quasiquoted-match-pat #'head) + . #,(transform-quasiquoted-match-pat #'tail))) + (#(pats ...) + (with-syntax (((pats* ...) #`(#,@(map-syntax + transform-quasiquoted-match-pat + #'(pats ...))))) + #'#(pats* ...))) + (other + #'other))) + + (define (transform-match-clauses clauses-forms) + #`(#,@(map-syntax (lambda (clause-form) + (syntax-case clause-form () + ((pat . body) + #`(#,(transform-match-pat #'pat) . body)))) + clauses-forms))) + + (define-syntax match-override + (lambda (x) + (syntax-case x () + ((_ expr . clauses) + #`(ice-9-match:match expr . #,(transform-match-clauses #'clauses)))))) + + (define-syntax match-lambda-override + (lambda (x) + (syntax-case x () + ((_ . clauses) + #`(ice-9-match:match-lambda + . #,(transform-match-clauses #'clauses)))))) + + (define-syntax match-lambda*-override + (lambda (x) + (syntax-case x () + ((_ . clauses) + #`(ice-9-match:match-lambda* + . #,(transform-match-clauses #'clauses)))))) + + (define transform-match-bindings + transform-match-clauses) + + (define-syntax match-let-override + (lambda (x) + (syntax-case x () + ((_ variable bindings . body) + (identifier? #'variable) + #`(ice-9-match:match-let variable + #,(transform-match-bindings #'bindings) + . body)) + ((_ bindings . body) + #`(ice-9-match:match-let #,(transform-match-bindings #'bindings) + . body))))) + + (define-syntax match-let*-override + (lambda (x) + (syntax-case x () + ((_ bindings . body) + #`(ice-9-match:match-let* #,(transform-match-bindings #'bindings) + . body))))) + + (define-syntax match-letrec-override + (lambda (x) + (syntax-case x () + ((_ bindings . body) + #`(ice-9-match:match-letrec #,(transform-match-bindings #'bindings) + . body)))))) + +;;; Local Variables: +;;; eval: (put 'format-identifiers 'scheme-indent-function 1) +;;; eval: (put 'record-spec-set-finalize 'scheme-indent-function 1) +;;; eval: (put 'record-spec-set-export? 'scheme-indent-function 1) +;;; eval: (put 'record-spec-set-fields 'scheme-indent-function 1) +;;; eval: (put 'record-init-set-fields 'scheme-indent-function 1) +;;; End: |