;;; record-builder.ss -- tools for constructing record types in Scheme

;;; John David Stone
;;; Department of Mathematics and Computer Science
;;; Grinnell College
;;; stone@cs.grinnell.edu

;;; created April 29, 1997
;;; last revised April 24, 2000

;;; The GENERATE-RECORD-DEFINITION-FILE procedure takes as its first
;;; argument a symbol, to be used as the name of a record type, and, as
;;; subsequent arguments, zero or ``field specifications,'' one for each
;;; field of the record.  Each field specification must be a list of four
;;; symbols: (1) the name of the field; (2) the name of a precondition
;;; predicate, usually a type predicate, that a value must satisfy to be
;;; stored in that field; (3) the name of a procedure to be used in testing
;;; equality of corresponding fields in different records; and (4) a
;;; procedure to be used for copying a field into a new record (or the
;;; symbol 'IDENTITY, indicating that the original value of the field can
;;; be used as its own copy).

;;; This procedure creates a file in the user's current working
;;; directory, containing Scheme definitions for procedures that
;;; collectively implement the record type: a constructor, selector and
;;; mutator procedures for each of the fields, a type predicate, an
;;; identity tester, and a copier.  The name of the file consists of the
;;; name of the record type followed by "-definition.ss".

(define generate-record-definition-file
  (lambda (record-name . fields)
    (let* ((record-name-string (symbol->string record-name))
           (definition-file-name (string-append record-name-string
                                                "-definition.ss"))
           (target (open-output-file definition-file-name)))
      
        ;; Print an explanatory header into the definition file.

        (print-explanatory-header definition-file-name
                                  record-name-string
                                  target)

        ;; Build the definition of a procedure that produces a type mark on
        ;; demand and write it to the definition file.

        (write (type-marker-maker record-name) target)
        (newline target)

        ;; Build the constructor definition as a datum and write it to
        ;; the definition file.

        (write (constructor-maker record-name fields) target)
        (newline target)

        ;; Do the same for each of the selectors and mutators.

        (let kernel ((rest fields)
                     (position 1))
          (if (not (null? rest))
              (let ((first (car rest)))
                (write (field-selector-maker record-name first position)
                         target)
                (newline target)
                (write (field-mutator-maker record-name first position)
                         target)
                (newline target)
                (kernel (cdr rest) (+ position 1)))))

        ;; Do the same for the type tester.

        (write (type-tester-maker record-name fields) target)
        (newline target)

        ;; Do the same for the identity tester.

        (write (identity-tester-maker record-name fields) target)
        (newline target)

        ;; Do the same for the copier.

        (write (copier-maker record-name fields) target)
        (newline target)

        ;; Close the definition file.

        (close-output-port target))))

;;; The STRING-UPCASE procedure constructs and returns a string just like
;;; its argument except that all lower-case letters have been converted
;;; to upper case.

(define string-upcase
  (lambda (str)
    (let* ((len (string-length str))
           (result (make-string len)))
      (do ((position 0 (+ position 1)))
          ((= position len) result)
        (string-set! result position 
                     (char-upcase (string-ref str position)))))))

;;; The PRINT-EXPLANATORY-HEADER procedure prints a description of the
;;; file's contents to a specified output port.

(define print-explanatory-header
  (lambda (file-name record-name-string target)
    (display ";;; " target)
    (display file-name target)
    (display " -- an implementation of the " target)
    (display (string-upcase record-name-string) target)
    (display " record type." target)
    (newline target)
    (display ";;; This file was generated by " target)
    (display "the RECORD-BUILDER code generator." target)
    (newline target)
    (newline target)))

;;; The following procedures generate symbols that name the various
;;; procedures that will be defined in the target file.

(define type-marker-name
  (lambda (record-name)
    (string->symbol (string-append "produce-"
                                   (symbol->string record-name)
                                   "-mark"))))

(define constructor-name
  (lambda (record-name)
    (string->symbol (string-append "make-" (symbol->string record-name)))))

(define selector-name
  (lambda (record-name field-name)
    (string->symbol (string-append (symbol->string record-name)
                                   "-"
                                   (symbol->string field-name)))))

(define mutator-name
  (lambda (record-name field-name)
    (string->symbol (string-append (symbol->string record-name)
                                   "-"
                                   (symbol->string field-name)
                                   "-set!"))))

(define type-tester-name
  (lambda (record-name)
    (string->symbol (string-append (symbol->string record-name) "?"))))

(define identity-tester-name
  (lambda (record-name)
    (string->symbol (string-append (symbol->string record-name) "=?"))))

(define copier-name
  (lambda (record-name)
    (string->symbol (string-append (symbol->string record-name) "-copy"))))

;;; The TYPE-MARKER-MAKER procedure builds and returns a Scheme datum that
;;; has the right form to be the definition of a procedure that returns a
;;; type mark for a specified record type when invoked.

(define type-marker-maker
  (lambda (record-name)
    `(define ,(type-marker-name record-name)
       (let ((type-mark (list ',record-name)))
         (lambda () type-mark)))))

;;; The CONSTRUCTOR-MAKER procedure builds and returns a Scheme datum that
;;; has the right form to be a definition of a constructor procedure for the
;;; specified record type.

(define constructor-maker
  (lambda (record-name fields)
    (let ((field-names (map car fields))
          (vector-size (+ (length fields) 1))
          (mutators
           (let kernel ((rest fields))
             (if (null? rest)
                 null
                 (let ((field-name (caar rest)))
                   (cons `(,(mutator-name record-name field-name)
                           result
                           ,field-name)
                         (kernel (cdr rest))))))))
      `(define ,(constructor-name record-name)
         (lambda ,field-names
           (let ((result (make-vector ,vector-size)))
             (vector-set! result 0 (,(type-marker-name record-name)))
             ,@mutators
             result))))))

;;; The FIELD-SELECTOR-MAKER procedure takes the name of a record type, the
;;; four-element specification of a field within that record, and the
;;; position of the field within the vector that implements the record, and
;;; constructs and returns a Scheme datum that has the right form to be a
;;; selector procedure for that field of that record.

(define field-selector-maker
  (lambda (record-name field position)
    (let* ((record-name-string (symbol->string record-name))
           (initial (string->symbol (substring record-name-string 0 1)))
           (field-name (car field)))
      `(define ,(selector-name record-name field-name)
         (lambda (,initial)
           (vector-ref ,initial ,position))))))

;;; The FIELD-MUTATOR-MAKER procedure takes the name of a record type, the
;;; four-element specification of a field within that record, and the
;;; position of the field within the vector that implements the record, and
;;; constructs and returns a Scheme datum that has the right form to be a
;;; mutator procedure for that field of that record.

(define field-mutator-maker
  (lambda (record-name field position)
    (let* ((record-name-string (symbol->string record-name))
           (initial (string->symbol (substring record-name-string 0 1)))
           (field-name (car field))
           (precondition (cadr field))
           (this-name (mutator-name record-name field-name))
           (this-name-string (symbol->string this-name))
           (parameter-name
            (string->symbol (string-append "new-"
                                           (symbol->string field-name)))))
      `(define ,this-name
         (lambda (,initial ,parameter-name)
           (if (,precondition ,parameter-name)
               (vector-set! ,initial ,position ,parameter-name)
               (error (string-append ,this-name-string
                                     ": Precondition failed"))))))))

;;; The TYPE-TESTER-MAKER procedure builds a Scheme datum that has the
;;; right form to be a definition of a type-testing predicate for the
;;; specified record type.

(define type-tester-maker
  (lambda (record-name fields)
    (let ((vector-size (+ (length fields) 1))
          (field-tests
           (let kernel ((rest fields)
                        (position 1))
             (if (null? rest)
                 null
                 (let ((precondition (cadar rest)))
                   (cons `(,precondition (vector-ref something ,position))
                         (kernel (cdr rest) (+ position 1))))))))
      `(define ,(type-tester-name record-name)
         (lambda (something)
           (and (vector? something)
                (= (vector-length something) ,vector-size)
                (eq? (vector-ref something 0)
                     (,(type-marker-name record-name)))
                ,@field-tests))))))

;;; The IDENTITY-TESTER-MAKER procedure builds a Scheme datum that has the
;;; right form to be a definition of an identity-testing predicate for the
;;; specified record type.

(define identity-tester-maker
  (lambda (record-name fields)
    (let ((field-tests
           (let kernel ((rest fields))
             (if (null? rest)
                 null
                 (let ((selector (selector-name record-name (caar rest)))
                       (comparer (caddar rest)))
                   (cons `(,comparer (,selector left) (,selector right))
                         (kernel (cdr rest))))))))
      `(define ,(identity-tester-name record-name)
         (lambda (left right)
           (and ,@field-tests))))))

;;; The COPIER-MAKER procedure builds a Scheme datum that has the right
;;; form to be a definition of a procedure that copies values of the
;;; specified record type.

(define copier-maker
  (lambda (record-name fields)
    (let* ((initial
            (string->symbol (substring (symbol->string record-name) 0 1)))
           (field-copying
            (let kernel ((rest fields))
              (if (null? rest)
                  null
                  (let ((selector (selector-name record-name (caar rest)))
                        (copier (cadddr (car rest))))
                    (cons (if (eq? copier 'identity)
                              `(,selector ,initial)
                              `(,copier (,selector ,initial)))
                          (kernel (cdr rest))))))))
      `(define ,(copier-name record-name)
         (lambda (,initial)
           (,(constructor-name record-name)
            ,@field-copying))))))