;; -*- mode: Scheme; -*-
;;
;; This file is part of Protocol Buffers for CHICKEN
;; Copyright (c) 2013 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(define-record-type (foo
                     #:uid '4b9aa808-96ef-48e3-bb97-d71f37068fe1)
  #t #t
  a b)

(define (read-bar port)
  (make-bar (read-string #f port)))

(define (write-bar v port)
  (write-string (bar-ref v) #f port))

(define-record-type (bar
                     #:property prop:serialization-info
                     (make-serialization-info read-bar write-bar))
  #t #t
  ref)

(define (serialize+deserialize v)
  (call-with-input-string
   (call-with-output-string (cut serialize v <>))
   deserialize))

(define (test-invariance v #!optional [compare equal?])
  (test-assert (format "~s" v) (compare v (serialize+deserialize v))))

(define (mul42 x)
  (* x 42))

(define (test-generic)
  (test-group "generic serialization"

    (test-group "immediate objects"
      (test-invariance (void) eq?)
      (test-invariance '() eq?)
      (test-invariance #!eof eq?)
      (test-invariance #f eq?)
      (test-invariance #t eq?)
      (test-invariance #\x eq?))

    (test-group "numbers"
      (test-invariance 42 =)
      (test-invariance 23.45 =)

      (test-invariance 42+23i =)
      (test-invariance 4/2+2/3i =)
      (test-invariance 0+2.34i =)
      (test-invariance 2.34+3.56i =))

    (test-group "strings"
      (test-invariance "foo"))

    (test-group "symbols"
      (test-invariance 'blubb eq?)
      (test-invariance #:troet eq?)

      (let* ([sym0 (gensym 'blubb)]
             [sym1 (serialize+deserialize sym0)])
        (test "gensym naming" (symbol->string sym1) (symbol->string sym0))
        (test-assert "gensym identity" (not (eq? sym1 sym0)))))

    (test-group "lists"
      (test-invariance (cons 1 2))
      (test-invariance '(a b 42))

      (let* ([lst0 (circular-list 1 2 3)]
             [lst1 (serialize+deserialize lst0)])
        (test-assert (eq? (cdddr lst1) lst1))
        (test (car lst0) (car lst1))
        (test (cadr lst0) (cadr lst1))
        (test (caddr lst0) (caddr lst1))))

    (test-group "vectors"
      (test-invariance '#(42+23i "foo"))

      (let ([vec0 (vector 'a 'b (void))])
        (vector-set! vec0 2 vec0)
        (let ([vec1 (serialize+deserialize vec0)])
          (test-assert (eq? (vector-ref vec1 2) vec1))
          (test (vector-ref vec0 0) (vector-ref vec1 0))
          (test (vector-ref vec0 1) (vector-ref vec1 1)))))

    (test-group "hash tables"
      (let* ([lst0 '(("blubb" . 23) ("boing" . 42))]
             [lst1 (sort
                    (hash-table->alist
                     (serialize+deserialize
                      (alist->hash-table lst0 #:test string=? #:hash string-hash)))
                    (lambda (a b)
                      (string<? (car a) (car b))))])
        (test lst0 lst1))

      (let* ([lst0 '((3 . "boo") (55 . "hoo"))]
             [lst1 (sort
                    (hash-table->alist
                     (serialize+deserialize
                      (alist->hash-table lst0)))
                    (lambda (a b)
                      (< (car a) (car b))))])
        (test lst0 lst1)))

    (test-group "procedures"
      (test 84 ((serialize+deserialize mul42) 2)))

    (test-group "homogeneous blobs"
      (test-invariance '#u8(1 2 3))
      (test-invariance '#s8(-1 0 +1))
      (test-invariance '#u16(1 2 3))
      (test-invariance '#s16(-1 0 +1))
      (test-invariance '#u32(1 2 3))
      (test-invariance '#s32(-1 0 +1))
      (test-invariance '#u64(1 2 3))
      (test-invariance '#s64(-1 0 +1))
      (test-invariance '#f32(1.234 5.678))
      (test-invariance '#f64(1.234 5.678))
      (test-invariance '#${983729423476237887246302}))

    (test-group "records"
      (test-invariance (make-foo 42+23i "Hallo Welt!"))
      (test-invariance (make-bar "kawumm!")))
    
    ))

;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;