;;;;;; serializer.rkt - YAML serializer.    -*- Mode: Racket -*-

#lang racket

(require
 "emitter.rkt"
 "errors.rkt"
 "events.rkt"
 "nodes.rkt"
 "resolver.rkt"
 "utils.rkt")

(provide make-serializer)

(define ANCHOR-TEMPLATE "id~a")

(define (serializer-error msg) (error 'serializer msg))

(define (make-serializer [out (current-output-port)]
                         #:canonical [canonical #f]
                         #:indent [default-indent #f]
                         #:width [default-width #f]
                         #:allow-unicode [allow-unicode #f]
                         #:line-break [line-break #f]
                         #:explicit-start [explicit-start #f]
                         #:explicit-end [explicit-end #f]
                         #:version [version #f]
                         #:tags [tags #f])
  (define emit (make-emitter out
                             #:canonical canonical
                             #:indent default-indent
                             #:width default-width
                             #:allow-unicode allow-unicode
                             #:line-break line-break))
  (define serialized-nodes (make-hasheq))
  (define anchors (make-hasheq))
  (define last-anchor-id 0)
  (define closed 'None)

  (define (open)
    (cond
     [(eq? 'None closed)
      (emit (stream-start-event #f #f))
      (set! closed #f)]
     [(eq? #t closed)
      (serializer-error "serializer is closed")]
     [else
      (serializer-error "serializer is already opened")]))

  (define (close)
    (cond
     [(eq? 'None closed)
      (serializer-error "serializer is not opened")]
     [(eq? #f closed)
      (emit (stream-end-event #f #f))
      (set! closed #t)]))

  (define (serialize node)
    (cond
     [(eq? 'None closed)
      (serializer-error "serializer is not opened")]
     [(eq? #t closed)
      (serializer-error "serializer is closed")])
    (emit (document-start-event #f #f explicit-start version tags))
    (anchor-node node)
    (serialize-node node)
    (emit (document-end-event #f #f explicit-end))
    (set! serialized-nodes (make-hasheq))
    (set! anchors (make-hasheq))
    (set! last-anchor-id 0))

  (define (anchor-node node)
    (cond
     [(hash-has-key? anchors node)
      (unless (hash-ref anchors node)
        (hash-set! anchors node (generate-anchor node)))]
     [else
      (hash-set! anchors node #f)
      (cond
       [(sequence-node? node)
        (for ([item (sequence-node-value node)])
          (anchor-node item))]
       [(mapping-node? node)
        (for ([kv (mapping-node-value node)])
          (anchor-node (car kv))
          (anchor-node (cdr kv)))])]))

  (define (generate-anchor node)
    (set! last-anchor-id (add1 last-anchor-id))
    (let ([str (number->string last-anchor-id)])
      (while (< (string-length str) 3)
        (set! str (string-append "0" str)))
      (format ANCHOR-TEMPLATE str)))

  (define (serialize-node node)
    (let ([alias (hash-ref anchors node)])
      (cond
       [(hash-has-key? serialized-nodes node)
        (emit (alias-event #f #f alias))]
       [else
        (hash-set! serialized-nodes node #t)
        (cond
         [(scalar-node? node)
          (let* ([tag (scalar-node-tag node)]
                 [value (scalar-node-value node)]
                 [style (scalar-node-style node)]
                 [detected-tag
                  (resolve 'scalar value (cons #t #f))]
                 [default-tag
                   (resolve 'scalar value (cons #f #t))]
                 [implicit (cons (equal? tag detected-tag)
                                 (equal? tag default-tag))])
            (emit (scalar-event #f #f alias tag implicit value style)))]
         [(sequence-node? node)
          (let* ([tag (sequence-node-tag node)]
                 [value (sequence-node-value node)]
                 [implicit (equal? tag (resolve 'sequence value #t))]
                 [flow-style (sequence-node-flow-style node)])
            (emit (sequence-start-event #f #f alias tag implicit flow-style))
            (for ([item value])
              (serialize-node item))
            (emit (sequence-end-event #f #f)))]
         [(mapping-node? node)
          (let* ([tag (mapping-node-tag node)]
                 [value (mapping-node-value node)]
                 [implicit (equal? tag (resolve 'mapping value #t))]
                 [flow-style (mapping-node-flow-style node)])
            (emit
             (mapping-start-event #f #f alias tag implicit flow-style))
            (for ([kv value])
              (serialize-node (car kv))
              (serialize-node (cdr kv)))
            (emit (mapping-end-event #f #f)))])])))

  (values open close serialize))