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

;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College

;; April 29-30, 1997

;; 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 more symbols to be used as names of fields
;; of the record.  It creates a file in the user's current working
;; directory, containing Scheme definitions for procedures that
;; collectively implement the record type: a constructor, a type predicate,
;; and selector and mutator procedures for each of the fields.  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-string (symbol->string record-name))
           (definition-file-name (string-append record-string
                                                "-definition.ss"))
           (target (open-output-file definition-file-name)))
      
        ;; Print an explanatory header into the definition file.

        (display ";; "target)
        (display definition-file-name target)
        (display " -- an implementation of the " target)
        (display (string-upcase record-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)

        ;; Build the constructor definition as a datum and write it to
        ;; the definition file.  In this step, we use the non-standard
        ;; PRETTY-PRINT procedure, which writes out Scheme data with
        ;; appropriate indentation and spacing. 

        (pretty-print (constructor-maker record-name fields) target)
        (newline target)

        ;; Do the same for the type tester.

        (pretty-print (type-tester-maker record-name fields) target)
        (newline target)

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

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

        ;; Close the definition file.

        (close-output-port target))))

;; 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 field-names)
    (let ((constructor-name
           (string->symbol (string-append "make-"
                                          (symbol->string record-name)))))
      `(define ,constructor-name
         (lambda ,field-names
           (vector ',record-name ,@field-names))))))

;; 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, then writes that datum out to the definition
;; file.

(define type-tester-maker
  (lambda (record-name field-names)
    (let ((tester-name
           (string->symbol (string-append (symbol->string record-name)
                                          "?"))))
      `(define ,tester-name
         (lambda (obj)
           (and (vector? obj)
                (= (vector-length obj) ,(+ (length field-names) 1))
                (eq? (vector-ref obj 0) ',record-name)))))))

;; The FIELD-SELECTOR-MAKER procedure takes the name of a record type,
;; the name 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-name position)
    (let* ((record-string (symbol->string record-name))
           (selector-name
            (string->symbol (string-append record-string "-"
                                           (symbol->string field-name))))
           (type-tester-name
            (string->symbol (string-append record-string "?")))
           (initial (string->symbol (substring record-string 0 1))))
      `(define ,selector-name
         (lambda (,initial)
           (if (not (,type-tester-name ,initial))
               (error ',selector-name
                      ,(string-append "The argument must be of type "
                                      (string-upcase record-string))))
           (vector-ref ,initial ,position))))))

;; The FIELD-MUTATOR-MAKER procedure takes the name of a record type,
;; the name 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-name position)
    (let* ((record-string (symbol->string record-name))
           (field-string (symbol->string field-name))
           (mutator-name
            (string->symbol (string-append "set-" record-string "-"
                                           field-string "!")))
           (type-tester-name
            (string->symbol (string-append record-string "?")))
           (initial (string->symbol (substring record-string 0 1)))
           (parameter-name (string->symbol (string-append "new-"
                                                          field-string))))
      `(define ,mutator-name
         (lambda (,initial ,parameter-name)
           (if (not (,type-tester-name ,initial))
               (error ',mutator-name
                      ,(string-append "The first argument must be of type "
                                      (string-upcase record-string))))
           (vector-set! ,initial ,position ,parameter-name))))))

;; 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)))))))