(module tagged-netstring

(tagged-netstring-read tagged-netstring-write)

(import chicken scheme)
(use netstring ports extras data-structures)

(define (tagged-netstring-read #!optional (port (current-input-port)))
  (let ((payload (netstring-read port #f))
        (type (read-char port)))

    (case type
      ((#!eof) payload)
      ((#\,) payload)
      ((#\#) (or (string->number payload)
                 (error 'tagged-netstring-read "invalid number" payload)))
      ((#\!) (cond ((string=? payload "true") #t)
                   ((string=? payload "false") #f)
                   (else (error 'tagged-netstring-read "invalid boolean" payload))))
      ((#\~) (if (zero? (string-length payload))
                 'null
                 (error "invalid null value" payload)))
      ((#\}) (parse-dict payload))
      ((#\]) (parse-list payload))
      (else (error "invalid payload type" type)))))

(define (parse-list data)
  (call-with-input-string data
    (lambda (port)
      (list->vector (read-file port tagged-netstring-read)))))

(define (read-key-value-pair port)
  (let ((key (netstring-read port #f)))
    (cond ((eof-object? key) key)
          ((not (eq? #\, (read-char port)))
           (error 'read-key-value-pair "invalid key (only strings are allowed)"))
          (else (let ((value (tagged-netstring-read port)))
                  (if (eof-object? value)
                      (error 'read-key-value-pair "incomplete pair")
                      (cons (string->symbol key) value)))))))

(define (parse-dict data)
  (call-with-input-string data
    (lambda (port)
      (read-file port read-key-value-pair))))


(define (tagged-netstring-write data #!optional (port (current-output-port)))
  (cond ((string? data) (netstring-write data port))
        ((integer? data) (netstring-write (number->string data) port #\#))
        ((boolean? data) (netstring-write (if data "true" "false") port #\!))
        ((vector? data) (write-array data port))
        ((list? data) (write-dict data port))
        (else (error 'tagged-netstring-write 
                     "datum cannot be represented as a tagged netstring"
                     data))))

(define (write-array data port)
  (netstring-write 
   (with-output-to-string
       (lambda ()
         (let loop ((i 0))
           (unless (= i (vector-length data))
             (tagged-netstring-write (vector-ref data i))
             (loop (+ 1 i))))))
   port
   #\]))

(define (write-dict data port)
  (netstring-write
   (with-output-to-string
       (lambda ()
         (let loop ((rest data))
           (unless (null? rest)
             (if (not (pair? (car rest)))
                 (error 'netstring-write "not a pair" rest)
                 (let* ((key (caar rest))
                        (key (if (symbol? key) (symbol->string key) key)))
                   (if (string? key)
                       (let ((value (cdar rest)))
                         (if (null? value)
                             (error 'netstring-write "incomplete pair" (car rest))
                             (begin (netstring-write key)
                                    (tagged-netstring-write value))))
                       (error "key must be symbol or string" key))))
             (loop (cdr rest))))))
   port
   #\}))

)