;;; Reimplementation of define-record from scsh for Guile Facade
;;; Copyright (c) 2010 Clinton Ebadi

;;; Deficiences:
;;; - copy-RECORD is not provided
;;; - disclose method must be the last field specified
;;; That should be the only thing

(define-module (scsh define-record)
  #:export (define-record))

;;; Emulates the scsh printer behavior
(define (make-record-printer printer)
  (lambda (record port)
    (let ((print-representation (printer record)))
      (display "#{" port)
      (display (car print-representation) port)
      (let pl ((slots (cdr print-representation)))
	(if (pair? slots)
	    (begin
	      (display " " port)
	      (write (car slots) port)
	      (pl (cdr slots)))))
      (display "}" port))))

(define-syntax define-record
  (lambda (e)
    (let ((expand-field (lambda (f)
			  (syntax-case f ()
			    ((fname) (syntax (field fname #f)))
			    ((fname default) (syntax (field fname default)))
			    (fname (syntax (field fname #f)))))))
      (syntax-case e (disclose)
	((_ name field0 field1 ... ((disclose x) body ...))
	 (identifier? (syntax x))
	 (with-syntax (((%fields ...)
			(map expand-field (syntax (field0 field1 ...)))))
	   (syntax
	    (define-record* name (make-record-printer (lambda (x)
							body ...))
	      %fields ...))))
	((_ name field0 field1 ...)
	 (with-syntax (((%fields ...)
			(map expand-field (syntax (field0 field1 ...)))))
	   (syntax
	    (define-record* name #f
	      %fields ...))))))))

(define-syntax define-record*
  (lambda (e)
    (letrec ((make-name (lambda args
			  (datum->syntax e
			   (string->symbol
			    (apply string-append
				   (map (lambda (a)
					  (if (string? a)
					      a
					      (symbol->string
					       (syntax->datum a))))
					args)))))))
      (syntax-case e (field)
	((_ name printer (field field-name default) ...)
	 (let ((%type-name (make-name "type/" (syntax name))))
	   (with-syntax
	       ((constructor (make-name "make-" (syntax name)))
		(predicate (make-name (syntax name) "?"))
		(name-string (symbol->string
			      (syntax->datum (syntax name))))
		((field-accessors ...)
		 (map
		  (lambda (f)
		    (syntax-case f ()
		      ((field-name default)
		       #`(begin
			   (define #,(make-name (syntax name)
						":"
						(syntax field-name))
			     (record-accessor #,%type-name 'field-name))
			   (define #,(make-name "set-"
						(syntax name)
						":"
						(syntax field-name))
			     (record-modifier #,%type-name 'field-name))
			   (define #,(make-name "modify-"
						(syntax name)
						":"
						(syntax field-name))
			     (let ((rm (record-modifier #,%type-name 'field-name))
				   (ra (record-accessor #,%type-name 'field-name)))
			       (lambda (record closure)
				 (rm record (closure (ra record))))))))))
		  (syntax ((field-name default) ...)))))
	     
	     #`(begin
		 (define #,%type-name (make-record-type name-string
						     '(field-name ...)
						     printer))

		 ;; record-constructor involves a call to
		 ;; primitive-eval--important to cache it
		 (define constructor
		   (let ((rc (record-constructor #,%type-name)))
		     (lambda* (#:optional (field-name default) ...)
			 (rc field-name ...))))
	       
		 (define predicate (record-predicate #,%type-name))
		 	       
		 field-accessors ...))))))))