;     Guile Scheme Data Serializer, part of Guile Web
;     Copyright (C) 2002 Clinton Ebadi

;     This program is free software; you can redistribute it and/or modify
;     it under the terms of the GNU General Public License as published by
;     the Free Software Foundation; either version 2 of the License, 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 the
;     GNU General Public License for more details.

;     You should have received a copy of the GNU General Public License
;     along with this program; if not, write to the Free Software
;     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA


(define-module (web serialize)
  #:export (serialize unserialize add-unserializer
	    serializer unserializer)
  #:use-module (oop goops)
  #:use-module (ice-9 optargs))

(define unserial-table (make-hash-table 50))

(define-generic serialize)

(define-method (serialize (item <top>))
  ;; This is the default version of serialize. An attempt to
  ;; unserialize data serialized with this function will result in the
  ;; variable having the value of #f
  (object->string (cons '<top> #f)))

(define (add-unserializer type de-serialize)
  (if (procedure? de-serialize)
    (hashq-create-handle! unserial-table type de-serialize)
    (error "Unserializer is not a procedure" de-serialize)))

(define (unserialize serialized-object)
  (if (string? serialized-object)
    (let ((s (read (open-input-string serialized-object))))
      (if (pair? s)
	(let* ((type (car s))
	       (value (cdr s))
	       (proc (hashq-ref unserial-table type)))
	  (if proc
	    (proc value)
	    #f ))
	#f))
    #f))

;;; takes an alist in the form
;;; ((var1 . value1) ... (varN . valueN))
;;; displays to port (defaults to (current-output-port)
(define* (serializer alist #:optional (port (current-output-port)))
  (if (and (list? alist) (port? port))
    (let loop ((alist alist))
      (cond ((null? alist))
	    (else
	     (let ((var (caar alist))
		   (val (cdar alist)))
	       (write (cons var (serialize val)) port))
	     (loop (cdr alist)))))
    (error "Alist or port of wrong type!" alist port)))
		      
;;; takes a port to read from as it's argument. This port must contain
;;; values that have been serialized by serializer. This will return
;;; an alist in the form:
;;; ((var1 . value1) ... (varN . valueN))

(define (unserializer port)
  (cond ((port? port)
	 (let loop ((alist (list))
		    (value (read port)))
	   (cond ((and (pair? value) (not (eof-object? value)))
		  (acons (car value) (unserialize (cdr value))
			 alist))
		 (else
		  alist ))))
	(else
	 (error "Port is not a a port!" port))))


;;; serializers and unserializers for built in types that I care
;;; about...please send patches to add new types (these are all the
;;; types that I noticed had goops classes when I wrote this).

;;; Serializations of simple types
(define-method (serialize (item <number>))
  (object->string (cons '<number> item)))

(define-method (serialize (item <char>))
  (object->string (cons '<char> item)))

(define-method (serialize (item <keyword>))
  (object->string (cons '<keyword> item)))

(define-method (serialize (item <string>))
  (object->string (cons '<string> item)))

(define-method (serialize (item <symbol>))
  (object->string (cons '<symbol> item)))

(define-method (serialize (item <boolean>))
  (object->string (cons '<boolean> item)))

;;; More complicated types
(define-method (serialize (item <vector>))
  (object->string (cons '<vector>
			(map serialize (vector->list item)))))

;;; Performance hack
(define (serialize-list item)
  (object->string (cons '<list>
			(map serialize item))))

(define-method (serialize (item <list>))
  (serialize-list item))

(define-method (serialize (item <pair>))
  (if (list? item) ; lists are also pairs...
      ;; I do this for efficiency; the output of (serialize-list) is
      ;; /much/ smaller than that of serializing the list as a pair
      (serialize-list item)
      (object->string (cons '<pair>
			    (cons 
			     (serialize (car item))
			     (serialize (cdr item)))))))

;;; add unserializers the easy way for basic types
(define (ret-arg x) x) ; save space
(for-each (lambda (x) (add-unserializer x ret-arg))
	  '(<number> <char> <keyword> <string> <symbol> <top> <boolean>))

(add-unserializer '<list>
		  (lambda (serial-list)
		    (map unserialize serial-list)))

(add-unserializer '<vector>
		  (lambda (serial-vector)
		    (list->vector (map unserialize serial-vector))))

(add-unserializer '<pair>
		 (lambda (serial-pair)
		   (cons (unserialize (car serial-pair))
			 (unserialize (cdr serial-pair)))))

;;; GOOPS Objects

(define-method (serialize (item <object>))
  (let ((class (class-of item)))
    (object->string
     (cons '<object>
	   (cons (class-name class)
		 (map (lambda (x)
			(cons (car x) (serialize (slot-ref item (car x)))))
		      (class-slots class)))))))
  
(add-unserializer '<object>
		  (lambda (object)
		    ;; I know eval is evil, this is the only way
		    (let*
			((class (eval (car object)
				      (interaction-environment)))
			 (new-object (make class)))
		      (for-each (lambda (x)
				  (slot-set! new-object (car x)
					     (unserialize (cdr x))))
				(cdr object))
		      new-object)))