;;;; sparse-vectors.print.scm

(module (sparse-vectors print)

(;export
  sparse-vector-print-style?
  sparse-vector-print-style
  sparse-vector-print-styles
  sparse-vector-print)

(import
  scheme
  (chicken base)
  (chicken type)
  (chicken bitwise)
  (chicken fixnum)
  (chicken format)
  record-variants
  sparse-vectors
  (sparse-vectors extras))

;NOTE works w/o recourse to `define-record' for tag, so ok for tag "defining" module
(cond-expand
  ((or chicken-5.0 chicken-5.1)
    (define (set-record-printer! tag proc)
      (##sys#register-record-printer tag proc) ) )
  (else) )

(include-relative "sparse-vectors.types")

(: sparse-vector-print-style? (* -> boolean))
(: sparse-vector-print-style (#!optional symbol -> symbol))
(: sparse-vector-print-styles (-> (list-of symbol)))

(: sparse-vector-print (sparse-vector #!optional output-port -> void))

;;

(include-relative "sparse-vectors-inlines")

(define-syntax print-define
  (syntax-rules ()
    ((print-define ?name ?fmt ?func)
      `(?name . (?fmt . ,?func)) ) ) )

(define PRINT-DEFINES `(
  ,(print-define describe
   "#<sparse-vector |~S| ~A>"
   (lambda (h) `(,(hilbert-def-value (hilbert-default h)) ,(hilbert-count h))))
  ,(print-define contents
    "#<sparse-vector ~S>"
    (lambda (h) `(,(sparse-vector->alist h))))
  #| ;um, useless
  ,(print-define debug/describe
    "#<sparse-vector |~S| ~S>"
    (lambda (h) `(,(hilbert-def-value (hilbert-default h))
                  ,(receive (sparse-vector-info h)))))
  ,(print-define debug/contents
    "#<sparse-vector |~S| ~S>"
    (lambda (h) `(,(hilbert-def-value (hilbert-default h)) ,(sparse-vector->list h))))
  |#
) )

(define (sparse-vector-printer hilbert style)
  (let ((def (assq style PRINT-DEFINES)))
    (if def (values (cadr def) ((cddr def) hilbert))
        ;internal error
        (error 'sparse-vector-printer "unknown style" style)) ) )

;;

(define (sparse-vector-print-styles) (map car PRINT-DEFINES))

(define (sparse-vector-print-style? x) (and (assq x PRINT-DEFINES) #t))

(define sparse-vector-print-style (make-parameter 'describe
  (lambda (x)
    (if (sparse-vector-print-style? x) x
        (begin
          (warning 'sparse-vector-print-style "must be one-of" (sparse-vector-print-styles) x)
          (sparse-vector-print-style))))))

;;

(define (sparse-vector-print hilbert #!optional (port (current-output-port)))
  (let-values (
    ((fmt args) (sparse-vector-printer (check-sparse-vector 'sparse-vector-print hilbert)
                                       (sparse-vector-print-style))) )
    (apply format port fmt args) ) )

(set-record-printer! sparse-vector sparse-vector-print)

) ;(sparse-vectors print)