;;; Procedure:
;;;   make-record
;;; Parameters:
;;;   fname, a string that gives the file in which to store the record.
;;;   type, a string that gives the name of the record
;;;   field 1 ... fieldn, pairs of fieldname/type (both as strings)
;;; Purpose:
;;;   Write a record type to the given file.
;;; Produces:
;;;   Nothing; called for side effects
(define make-record
  (lambda (fname type . fields)
    (let ((dest (open-output-file fname)))
      (write-header dest type)
      (write-typefun dest type)
      (write-constructor dest type fields)
      (write-selectors dest type fields)
      (write-mutators dest type fields)
      (write-misc dest type fields)
      (close-output-port dest))))
   
(define display-line
  (letrec ((kernel
            (lambda (port remaining)
              (if (null? remaining)
                  (newline port)
                  (begin
                    (display (car remaining) port)
                    (kernel port (cdr remaining)))))))
    (lambda (port . values)
      (kernel port values))))


(define write-header
  (lambda (port type)
    (display-line port ";;; File:")
    (display-line port ";;;  " type ".scm")
    (display-line port ";;; Author:")
    (display-line port ";;;  record-maker.scm, an automatic record generator written")
    (display-line port ";;;  by Samuel A. Rebelsky")
    (display-line port ";;; Summary:")
    (display-line port ";;;  Records of " type ".")
    (display-line port)
    ))

(define write-typefun
  (lambda (port type)
    (write-section port "Local Utilities")
    (display-line port "(define " type "-type-mark")
    (display-line port "  (let ((type-mark (list '" type ")))")
    (display-line port "    (lambda () type-mark)))")))

(define write-constructor
  (letrec ((params
            (lambda (port fields)
              (if (not (null? fields))
                  (begin
                    (display (caar fields) port)
                    (display " " port)
                    (params port (cdr fields))))))
           (set-fields 
            (lambda (port type fields)
              (if (not (null? fields))
                  (begin
                    (display-line port "      (set-" type "-" (caar fields) "! result " (caar fields) ")")
                    (set-fields port type (cdr fields)))))))
    (lambda (port type fields)
      (write-section port "Constructors")
      (display-line port "(define make-" type)
      (display "  (lambda (" port)
      (params port fields)
      (display-line port ")")
      (display-line port "    (let ((result (make-vector " (+ 1 (length fields)) ")))")
      (display-line port "      (vector-set! result 0 (" type "-type-mark))")
      (set-fields port type fields)
      (display-line port "      result)))")
      (display-line port))))

(define write-selectors
  (letrec ((kernel 
            (lambda (port type remaining pos)
              (if (not (null? remaining))
                  (begin
                    (display-line port "(define get-" type "-" (caar remaining))
                    (display-line port "  (lambda (" type ")")
                    (display-line port "    (vector-ref " type " " pos ")))")
                    (display-line port)
                    (kernel port type (cdr remaining) (+ pos 1)))))))
    (lambda (port type fields)
      (write-section port "Selectors")
      (kernel port type fields 1))))

(define write-mutators
  (letrec ((kernel 
            (lambda (port type remaining pos)
              (if (not (null? remaining))
                  (let ((procname (string-append "set-" type "-" (caar remaining) "!")))
                    (begin
                      (display-line port "(define " procname)
                      (display-line port "  (lambda (" type " " (caar remaining) ")")
                      (display-line port "    (if (" (cdar remaining) "? " (caar remaining) ")")
                      (display-line port "        (vector-set! " type " " pos " " (caar remaining) ")")
                      (display-line port "        (error '" procname)
                      (display-line port "               \"" (caar remaining) " must have type " (cdar remaining) "\"))))")
                      (display-line port)
                      (kernel port type (cdr remaining) (+ pos 1))))))))
    (lambda (port type fields)
      (write-section port "Mutators")
      (kernel port type fields 1))))

(define write-misc
  (letrec ((kernel
            (lambda (port type remaining pos)
              (if (not (null? remaining))
                  (begin
                    (display-line port "         (" (cdar remaining) "? (vector-ref val " pos "))")
                    (kernel port type (cdr remaining) (+ pos 1)))))))
    (lambda (port type fields)
      (write-section port "Miscellanous")
      (display-line port "(define " type "?")
      (display-line port "  (lambda (val)")
      (display-line port "    (and (vector? val)")
      (display-line port "         (= (vector-length val) " (+ 1 (length fields)) ")")
      (display-line port "         (eq? (vector-ref val 0) (" type "-type-mark))")
      (kernel port type fields 1)
      (display-line port "    )))")
      (display-line port))))

(define write-section
  (let ((dashes "----------------------------------------------------------------------------")
        (spaces "                                                                            "))
    (lambda (port section)
      (display-line port)
      (display-line port 
                    "; +-" (substring dashes 0 (string-length section))
                    "-+" (substring dashes 0 (- 65 (string-length section))))
      (display-line port 
                    "; | " section " |")
      (display-line port
                    "; +-" (substring dashes 0 (string-length section)) "-+" )
      (display-line port))))