srfi-9-plus.ss
#lang scheme/base
;;; @Package     srfi-9-plus
;;; @Subtitle    Enhanced define-record-type in PLT Scheme
;;; @HomePage    http://www.neilvandyke.org/srfi-9-plus/
;;; @Author      Neil Van Dyke
;;; @Version     0.1
;;; @Date        2009-11-28
;;; @PLaneT      neil/srfi-9-plus:1:0

;; $Id: srfi-9-plus.ss,v 1.14 2009/11/28 22:38:53 neilpair Exp $

;;; @legal
;;; Copyright @copyright{} 2009 Neil Van Dyke.  This program is Software; you
;;; can redistribute it and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software Foundation; either
;;; version 3 of the License (LGPL 3), or (at your option) any later version.
;;; This program is distributed in the hope that it will be useful, but without
;;; any warranty; without even the implied warranty of merchantability or
;;; fitness for a particular purpose.  See
;;; @indicateurl{http://www.gnu.org/licenses/} for details.  For other licenses
;;; and consulting, please contact the author.
;;; @end legal

;;; @section Introduction

;;; The @b{srfi-9-plus} library (almost completely) implements
;;; @uref{http://srfi.schemers.org/srfi-9/srfi-9.html, SRFI-9}, and adds a
;;; @code{define-record-type/write} syntax that is like
;;; @code{define-record-type} but extended to define a custom writer.
;;;
;;; This library does not completely implement SRFI-9 in that the
;;; @code{define-record-type} defined here requires that the sequence of field
;;; tags in the constructor match the initial sequence of field tags defined by
;;; the field specs.  That feature of SRFI-9 should not be necessary, since the
;;; field specs can be ordered to match the desired constructor arguments.
;;;
;;; This library was written for adding custom writing to some code that was
;;; implemented using SRFI-9, rather than rework that code to use
;;; @code{define-record-type} directly.  @b{srfi-9-plus} is currently
;;; implemented for PLT Scheme as a veneer over @code{make-struct-type},
;;; although that is not guaranteed.
;;;
;;; This documentation was written quickly.

;;; @section Interface

;; Note: I used "syntax-rules" because doing so was more difficult than using
;; "syntax-case", and this library is not 100% serious.

(define-syntax %syntax-error (syntax-rules () ((_) #f)))

;;; @defsyntax define-record-type/write type constructor-spec predicate write-proc field-specs ...
;;;
;;; This is like SRFI-9 @code{define-record-type}, except for the extra
;;; @var{write-proc} form, which is a PLT @code{struct}
;;; @code{prop:custom-write} procedure.  For example:
;;;
;;; @lisp
;;; (define (foo-write-proc record port write?)
;;;   (and write? (display "<<<foo " port))
;;;   (write (foo:aaa record) port)
;;;   (display " to " port)
;;;   (write (foo:bbb record) port)
;;;   (and write? (display ">>>" port)))
;;;
;;; (define-record-type/write foo
;;;   (make-foo aaa bbb)
;;;   foo?
;;;   foo-write-proc
;;;   (aaa foo:aaa)
;;;   (bbb foo:bbb foo:set-bbb!)
;;;   (ccc foo:ccc))
;;;
;;; (define x (make-foo 0 60))
;;;
;;; x @result{} <<<foo 0 to 60>>>
;;;
;;; (format "~A" x) @result{} "0 to 60"
;;; @end lisp

(define-syntax define-record-type/write
  (syntax-rules ()
    ((_ NAME
        CONSTRUCTOR-SPEC
        PREDICATE-NAME
        WRITE-PROC
        FIELD-SPEC ...)
     (%define-record-type/write:do-fields (FIELD-SPEC ...)
                                          () ; FIELD-TAGS
                                          () ; FIELD-ONES
                                          () ; ACC-MUT-NAMES
                                          () ; ACC-MUT-VALS
                                          CONSTRUCTOR-SPEC
                                          struct-accessor
                                          struct-mutator
                                          NAME
                                          PREDICATE-NAME
                                          WRITE-PROC))))

(define-syntax %define-record-type/write:do-fields
  ;; (_ FIELD-SPECS
  ;;    FIELD-TAGS
  ;;    FIELD-ONES
  ;;    ACC-MUT-NAMES
  ;;    ACC-MUT-VALS
  ;;    CONSTRUCTOR-SPEC
  ;;    STRUCT-ACCESSOR-NAME
  ;;    STRUCT-MUTATOR-NAME
  ;;    NAME
  ;;    PREDICATE-NAME
  ;;    WRITE-PROC)
  (syntax-rules ()

    ;; FIELD-SPEC with MUTATOR-NAME, so rewrite and recurse to then process the
    ;; accessor:
    ((_ ((FIELD-TAG ACCESSOR-NAME MUTATOR-NAME) FIELD-SPEC-1 ...)
        FIELD-TAGS
        (FIELD-ONE ...)
        (ACC-MUT-NAME ...)
        (ACC-MUT-VAL ...)
        CONSTRUCTOR-SPEC
        STRUCT-ACCESSOR-NAME
        STRUCT-MUTATOR-NAME
        NAME
        PREDICATE-NAME
        WRITE-PROC)
     (%define-record-type/write:do-fields
      ((FIELD-TAG ACCESSOR-NAME) FIELD-SPEC-1 ...)
      FIELD-TAGS
      (FIELD-ONE ...)
      (ACC-MUT-NAME ... MUTATOR-NAME)
      (ACC-MUT-VAL ...
                   (let ((MUTATOR-NAME
                          (lambda (x v)
                            (STRUCT-MUTATOR-NAME x (+ FIELD-ONE ...) v))))
                     MUTATOR-NAME))
      CONSTRUCTOR-SPEC
      STRUCT-ACCESSOR-NAME
      STRUCT-MUTATOR-NAME
      NAME
      PREDICATE-NAME
      WRITE-PROC))

    ;; FIELD-SPEC with ACCESSOR-NAME, so rewrite and recurse:
    ((_ ((FIELD-TAG ACCESSOR-NAME) FIELD-SPEC-1 ...)
        (FIELD-TAG-0 ...)
        (FIELD-ONE ...)
        (ACC-MUT-NAME ...)
        (ACC-MUT-VAL ...)
        CONSTRUCTOR-SPEC
        STRUCT-ACCESSOR-NAME
        STRUCT-MUTATOR-NAME
        NAME
        PREDICATE-NAME
        WRITE-PROC)
     (%define-record-type/write:do-fields
      (FIELD-SPEC-1 ...)
      (FIELD-TAG-0 ... FIELD-TAG)
      (1 FIELD-ONE ...)
      (ACC-MUT-NAME ... ACCESSOR-NAME)
      (ACC-MUT-VAL ...
                   (let ((ACCESSOR-NAME
                          (lambda (x)
                            (STRUCT-ACCESSOR-NAME x (+ FIELD-ONE ...)))))
                     ACCESSOR-NAME))
      CONSTRUCTOR-SPEC
      STRUCT-ACCESSOR-NAME
      STRUCT-MUTATOR-NAME
      NAME
      PREDICATE-NAME
      WRITE-PROC))

    ;; FIELD-SPECS exhausted:
    ((_ () ; FIELD-SPECS
        FIELD-TAGS
        FIELD-ONES
        ACC-MUT-NAMES
        ACC-MUT-VALS
        (CONSTRUCTOR-NAME CONSTRUCTOR-TAG-0 CONSTRUCTOR-TAG-1 ...)
        STRUCT-ACCESSOR-NAME
        STRUCT-MUTATOR-NAME
        NAME
        PREDICATE-NAME
        WRITE-PROC)
     (%define-record-type/write:do-constructor
      (CONSTRUCTOR-TAG-0 CONSTRUCTOR-TAG-1 ...)
      FIELD-TAGS
      () ; INIT-ONES
      () ; AUTO-ONES
      (CONSTRUCTOR-TAG-0 CONSTRUCTOR-TAG-1 ...)
      FIELD-TAGS
      ACC-MUT-NAMES
      ACC-MUT-VALS
      CONSTRUCTOR-NAME
      STRUCT-ACCESSOR-NAME
      STRUCT-MUTATOR-NAME
      NAME
      PREDICATE-NAME
      WRITE-PROC))

    ;; Error: FIELD-SPECS exhausted but previous didn't match:
    ((_ () X ...)
     (%syntax-error "invalid constructor spec"))))

(define-syntax %define-record-type/write:do-constructor
  ;; (_ CONSTRUCTOR-TAGS
  ;;    FIELD-TAGS
  ;;    INIT-ONES
  ;;    AUTO-ONES
  ;;    ORIG-CONSTRUCTOR-TAGS
  ;;    ORIG-FIELD-TAGS
  ;;    ACC-MUT-NAMES
  ;;    ACC-MUT-VALS
  ;;    CONSTRUCTOR-NAME
  ;;    STRUCT-ACCESSOR-NAME
  ;;    STRUCT-MUTATOR-NAME
  ;;    NAME
  ;;    PREDICATE-NAME
  ;;    WRITE-PROC)
  (syntax-rules ()

    ;; Scan a pair of tags.  (Note that we can't compare names using
    ;; syntax-rules, except perhaps with an Oleg trick.)
    ((_ (CONSTRUCTOR-TAG CONSTRUCTOR-TAG-1 ...)
        (FIELD-TAG FIELD-TAG-1 ...)
        (INIT-ONE ...)
        AUTO-ONES
        ORIG-CONSTRUCTOR-TAGS
        ORIG-FIELD-TAGS
        ACC-MUT-NAMES
        ACC-MUT-VALS
        CONSTRUCTOR-NAME
        STRUCT-ACCESSOR-NAME
        STRUCT-MUTATOR-NAME
        NAME
        PREDICATE-NAME
        WRITE-PROC)
     (%define-record-type/write:do-constructor
      (CONSTRUCTOR-TAG-1 ...)
      (FIELD-TAG-1 ...)
      (1 INIT-ONE ...)
      AUTO-ONES
      ORIG-CONSTRUCTOR-TAGS
      ORIG-FIELD-TAGS
      ACC-MUT-NAMES
      ACC-MUT-VALS
      CONSTRUCTOR-NAME
      STRUCT-ACCESSOR-NAME
      STRUCT-MUTATOR-NAME
      NAME
      PREDICATE-NAME
      WRITE-PROC))

    ;; Error: CONSTRUCTOR-TAG but no FIELD-TAG
    ((_ (CONSTRUCTOR-TAG CONSTRUCTOR-TAG-1 ...)
        ()
        INIT-ONES
        AUTO-ONES
        ORIG-CONSTRUCTOR-TAGS
        ORIG-FIELD-TAGS
        ACC-MUT-NAMES
        ACC-MUT-VALS
        CONSTRUCTOR-NAME
        STRUCT-ACCESSOR-NAME
        STRUCT-MUTATOR-NAME
        NAME
        PREDICATE-NAME
        WRITE-PROC)
     (%syntax-error "too many field tags in constructor" CONSTRUCTOR-TAG))

    ;; We're out of CONSTRUCTOR-TAGS but not FIELD-TAGS, so count the extra
    ;; field in AUTO-ONES.
    ((_ () ; CONSTRUCTOR-TAGS
        (FIELD-TAG FIELD-TAG-1 ...)
        INIT-ONES
        (AUTO-ONE ...)
        ORIG-CONSTRUCTOR-TAGS
        ORIG-FIELD-TAGS
        ACC-MUT-NAMES
        ACC-MUT-VALS
        CONSTRUCTOR-NAME
        STRUCT-ACCESSOR-NAME
        STRUCT-MUTATOR-NAME
        NAME
        PREDICATE-NAME
        WRITE-PROC)
     (%define-record-type/write:do-constructor
      () ; CONSTRUCTOR-TAGS
      (FIELD-TAG-1 ...)
      INIT-ONES
      (1 AUTO-ONE ...)
      ORIG-CONSTRUCTOR-TAGS
      ORIG-FIELD-TAGS
      ACC-MUT-NAMES
      ACC-MUT-VALS
      CONSTRUCTOR-NAME
      STRUCT-ACCESSOR-NAME
      STRUCT-MUTATOR-NAME
      NAME
      PREDICATE-NAME
      WRITE-PROC))

    ;; We're out of CONSTRUCTOR-TAGS and FIELD-TAGS, so finish.
    ((_ () ; CONSTRUCTOR-TAGS
        () ; FIELD-TAGS
        INIT-ONES
        AUTO-ONES
        ORIG-CONSTRUCTOR-TAGS
        ORIG-FIELD-TAGS
        ACC-MUT-NAMES
        ACC-MUT-VALS
        CONSTRUCTOR-NAME
        STRUCT-ACCESSOR-NAME
        STRUCT-MUTATOR-NAME
        NAME
        PREDICATE-NAME
        WRITE-PROC)
     (%define-record-type/write:last
      ORIG-CONSTRUCTOR-TAGS ; CONSTRUCTOR-TAGS
      ORIG-FIELD-TAGS ; FIELD-TAGS
      INIT-ONES
      AUTO-ONES
      ACC-MUT-NAMES
      ACC-MUT-VALS
      CONSTRUCTOR-NAME
      STRUCT-ACCESSOR-NAME
      STRUCT-MUTATOR-NAME
      NAME
      PREDICATE-NAME
      WRITE-PROC))))

(define-syntax %define-record-type/write:last
  ;; (_ CONSTRUCTOR-TAGS
  ;;    FIELD-TAGS
  ;;    INIT-ONES
  ;;    AUTO-ONES
  ;;    ACC-MUT-NAMES
  ;;    ACC-MUT-VALS
  ;;    CONSTRUCTOR-NAME
  ;;    STRUCT-ACCESSOR-NAME
  ;;    STRUCT-MUTATOR-NAME
  ;;    NAME
  ;;    PREDICATE-NAME
  ;;    WRITE-PROC)
  (syntax-rules ()
    ((_ (CONSTRUCTOR-TAG ...)
        (FIELD-TAG ...)
        (INIT-ONE ...)
        (AUTO-ONE ...)
        (ACC-MUT-NAME ...)
        (ACC-MUT-VAL ...)
        CONSTRUCTOR-NAME
        STRUCT-ACCESSOR-NAME
        STRUCT-MUTATOR-NAME
        NAME
        PREDICATE-NAME
        WRITE-PROC)
     (define-values (NAME
                     CONSTRUCTOR-NAME
                     PREDICATE-NAME
                     ACC-MUT-NAME ...)
       (let-values (((type
                      constructor
                      predicate
                      STRUCT-ACCESSOR-NAME
                      STRUCT-MUTATOR-NAME)
                     (make-struct-type (quote NAME)     ; name
                                       #f               ; super-type
                                       (+ INIT-ONE ...) ; init-field-count
                                       (+ AUTO-ONE ...) ; auto-field-count
                                       #f               ; auto-v
                                       (if WRITE-PROC
                                           (list (cons prop:custom-write
                                                       WRITE-PROC))
                                           '()))))
         (values type
                 (begin (%check-constructor 'define-struct-type/write
                                            constructor
                                            (quote (CONSTRUCTOR-TAG ...))
                                            (quote (FIELD-TAG ...)))
                        (let ((CONSTRUCTOR-NAME
                               (lambda (CONSTRUCTOR-TAG ...)
                                 (constructor CONSTRUCTOR-TAG ...))))
                          CONSTRUCTOR-NAME))
                 (let ((PREDICATE-NAME (lambda (x) (predicate x))))
                   PREDICATE-NAME)
                 ACC-MUT-VAL ...))))))

(define (%check-constructor error-sym struct-constructor c-tags f-tags)
  ;; Note: This procedure is the price we pay for not using "syntax-case".
  (let loop ((c-tags c-tags)
             (f-tags f-tags)
             (seen-tags '()))
    (if (null? c-tags)
        struct-constructor
        (if (null? f-tags)
            (error error-sym
                   "internal error: too many constructor tags")
            (let ((ct (car c-tags))
                  (ft (car f-tags)))
              (if (memq ct seen-tags)
                  (error error-sym
                         "field tag occurs multiply in constructor spec: ~S"
                         ct)
                  (if (eq? ct ft)
                      (loop (cdr c-tags) (cdr f-tags) (cons ct seen-tags))
                      ;; TODO: Instead of raising an error here, call a
                      ;; procedure to generate the wrapper procedure, and
                      ;; return that.  Perhaps that should not have been part
                      ;; of the SRFI.
                      (error error-sym
                             "constructor disagrees with field specs: ~S ~S"
                             ct
                             ft))))))))

;;; @defsyntax define-record-type type constructor-spec predicate field-specs ...
;;;
;;; This is like the SRFI-9 syntax of the same name.

(define-syntax define-record-type
  (syntax-rules ()
    ((_ TYPE CONSTRUCTOR-SPEC PREDICATE FIELD-SPECS ...)
     (define-record-type/write
       TYPE CONSTRUCTOR-SPEC PREDICATE #f FIELD-SPECS ...))))

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.1 --- 2009-11-28 --- PLaneT @code{(1 0)}
;;; Initial version.  Tested lightly.
;;;
;;; @end table

(provide
 define-record-type
 define-record-type/write)