;;; 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 (format-identifiers
(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)
(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 value-update-expr-rest ...)
(identifier? #'field-name)
(syntax->field-init #'(field-name #:=> (lambda (field-name)
value-update-expr
value-update-expr-rest ...))))
((field-name #:list value-item-expr value-item-expr-rest ...)
(syntax->field-init #'(field-name
(list value-item-expr
value-item-expr-rest ...))))))
(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* ((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 ((<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:
