;;; SPDX-License-Identifier: CC0-1.0 ;;; ;;; Copyright (C) 2023 Wojtek Kosior (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 (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 (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 (make-field-init) field-init? (name field-init-name field-init-set-name) (make-value-expr field-init-make-value-expr field-init-set-make-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-make-value-expr) (const #'value-expr)))) (field-name (identifier? #'field-name) (syntax->field-init #'(field-name field-name))) ((field-name #:=> value-update-proc) (identifier? #'field-name) (set-fields %null-field-init ((field-init-name) #'field-name) ((field-init-make-value-expr) (lambda (record-name record-base) #`(value-update-proc (#,(format-identifiers "~a-~a" record-name #'field-name) #,record-base)))))) ((field-name #:-> value-update-expr) (identifier? #'field-name) (syntax->field-init #'(field-name #:=> (lambda (field-name) value-update-expr)))))) (define-immutable-record-type (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* ((base #,(or inherit %null-record)) #,@(map (match-lambda ((and (= field-init-name field-name) (= field-init-make-value-expr make-value-expr)) #`(#,field-name #,(make-value-expr record-name #'base)))) field-inits)) (set-fields base #,@(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 (( (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 (--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-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: