(use s11n)

(define dump
  (lambda (x . len-out)
    (let-optionals len-out
	([len #f]
	 [out ##sys#standard-output] )
      (define (bestlen n) (if len (min len n) n))
      (cond [(##sys#immediate? x) (print "can not dump immediate object" x)]
	    [(##sys#bytevector? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
	    [(string? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
	    [(and (not (##sys#immediate? x)) (##sys#pointer? x))
	     (hexdump x 32 ##sys#peek-byte out) ]
	    [(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))
	     (let ([bv (##sys#slot x 1)])
	       (hexdump bv (bestlen (##sys#size bv)) ##sys#byte out) ) ]
	    [else (print "can not dump object" x)] ) ) ) )

(define hexdump
  (let ([display display]
	[string-append string-append]
	[make-string make-string]
	[write-char write-char] )
    (lambda (bv len ref out)

      (define (justify n m base lead)
	(let* ([s (number->string n base)]
	       [len (##sys#size s)] )
	  (if (fx< len m)
	      (string-append (make-string (fx- m len) lead) s)
	      s) ) )

      (do ([a 0 (fx+ a 16)])
	  ((fx>= a len))
	(display (justify a 4 10 #\space) out)
	(write-char #\: out)
	(do ([j 0 (fx+ j 1)]
	     [a a (fx+ a 1)] )
	    ((or (fx>= j 16) (fx>= a len))
	     (and-let* ([(fx>= a len)]
			[o (fxmod len 16)]
			[(not (fx= o 0))] )
	       (do ([k (fx- 16 o) (fx- k 1)])
		   ((fx= k 0))
		 (display "   " out) ) ) )
	  (write-char #\space out)
	  (display (justify (ref bv a) 2 16 #\0) out) )
	(write-char #\space out)
	(do ([j 0 (fx+ j 1)]
	     [a a (fx+ a 1)] )
	    ((or (fx>= j 16) (fx>= a len)))
	  (let ([c (ref bv a)])
	    (if (and (fx>= c 32) (fx< c 128))
		(write-char (integer->char c) out)
		(write-char #\. out) ) ) ) 
	(##sys#write-char-0 #\newline out) ) ) ) )

(define (pipe x #!optional pred (check #t))
  (let ((str (with-output-to-string (cut serialize x))))
    (##sys#with-print-length-limit 80 (cut print* x))
    (newline)
    (dump str)
    (let ((y (deserialize (open-input-string str))))
      (when pred (assert (pred y)))
      (when check (assert (equal? x y)))
      y) ) )

(pp (pipe 123))
(pp (pipe #\A))
(pp (pipe 'abc ##sys#interned-symbol?))
(pp (pipe (gensym) (complement ##sys#interned-symbol?) #f))
(pp (pipe abc: keyword?))
(pp (pipe "a test"))
(pp (pipe '#(this is "a test")))
(define p '(1))
(set-cdr! p p)
(pipe p (lambda (x) (eq? x (cdr x))) #f)
;(pp (pipe serialize))
;(pp (pipe (let ((x serialize)) (lambda () (print x))) (lambda (x) (x))))