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

#lang racket

(require
 srfi/13
 "errors.rkt"
 "events.rkt"
 "utils.rkt")

(provide make-emitter)

(define (emitter-error message)
  (error 'emitter message))

(struct scalar-analysis
  (scalar empty multiline allow-flow-plain allow-block-plain
          allow-single-quoted allow-double-quoted allow-block))

(define (make-emitter [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])
  (define DEFAULT-TAG-PREFIXES
    #hash(("!" . "!") ("tag:yaml.org,2002:" . "!!")))

  (define encoding #f)
  (define states '())
  (define (state) (expect-stream-start))
  (define events '())
  (define event #f)
  (define indents '())
  (define indent #f)
  (define flow-level 0)
  (define root-context #f)
  (define sequence-context #f)
  (define mapping-context #f)
  (define simple-key-context #f)
  (define line 0)
  (define column 0)
  (define whitespace #t)
  (define indention #t)
  (define open-ended #f)
  (define best-indent
    (if (and default-indent
             (< 1 default-indent 10))
        default-indent
        2))
  (define best-width
    (if (and default-width
             (> default-width (* 2 best-indent)))
        default-width
        80))
  (define best-line-break
    (if (member line-break '("\r" "\n" "\r\n"))
        line-break
        (string #\newline)))
  (define tag-prefixes #f)
  (define prepared-anchor #f)
  (define prepared-tag #f)
  (define analysis #f)
  (define style #f)

  (define (dispose)
    ;; Reset the state attributes (to clear self-references)
    (set! states '())
    (set! state #f))

  (define (emit evt)
    (append! events (list evt))
    (while (not (need-more-events?))
      (set! event (car events))
      (set! events (cdr events))
      (state)
      (set! event #f)))

  ;; In some cases, we wait for a few next events before emitting.

  (define (need-more-events?)
    (cond
     [(null? events) #t]
     [(document-start-event? (car events))
      (need-events? 1)]
     [(sequence-start-event? (car events))
      (need-events? 2)]
     [(mapping-start-event? (car events))
      (need-events? 3)]
     [else #f]))

  (define (need-events? count)
    (let loop ([level 0] [es (cdr events)])
      (if (null? es)
          (< (length events) (add1 count))
          (let ([e (car es)])
            (cond
             [(or (document-start-event? e)
                  (collection-start-event? e))
              (set! level (add1 level))]
             [(or (document-end-event? e)
                  (collection-end-event? e))
              (set! level (sub1 level))]
             [(stream-end-event? e)
              (set! level -1)])
            (and (>= level 0)
                 (loop level (cdr es)))))))

  (define (increase-indent [flow #f] [indentless #f])
    (append! indents (list indent))
    (if (eq? #f indent)
        (set! indent (if flow best-indent 0))
        (unless indentless
          (set! indent (+ indent best-indent)))))

  ;; States.

  ;; Stream handlers.

  (define (expect-stream-start)
    (cond
     [(stream-start-event? event)
      (write-stream-start)
      (set! state expect-first-document-start)]
     [else
      (emitter-error
       (format "expected stream-start, but got ~a"
               (event->string event)))]))

  (define (expect-nothing)
    (emitter-error
     (format "expected nothing, but got ~a"
             (event->string event))))

  ;; Document handlers.

  (define (expect-first-document-start)
    (expect-document-start #t))

  (define (expect-document-start [first #f])
    (cond
      [(document-start-event? event)
       (when (and (or (document-start-event-version event)
                      (document-start-event-tags event))
                  open-ended)
         (write-indicator "..." #t)
         (write-indent))
       (when (document-start-event-version event)
         (write-version-directive
          (prepare-version (document-start-event-version event))))
       (set! tag-prefixes (hash-copy DEFAULT-TAG-PREFIXES))
       (when (document-start-event-tags event)
         (let ([tags (document-start-event-tags event)])
           (for ([handle (sort (hash-keys tags) string<?)])
             (let ([prefix (hash-ref tags handle)])
               (hash-set! tag-prefixes prefix handle)
               (let* ([handle-text (prepare-tag-handle handle)]
                      [prefix-text (prepare-tag-prefix prefix)])
                 (write-tag-directive handle-text prefix-text))))))
       (unless (and first (not (document-start-event-explicit event))
                    (not canonical) (not (document-start-event-version event))
                    (or (not (hash? (document-start-event-tags event)))
                        (null? (hash-keys (document-start-event-tags event))))
                    (not (check-empty-document?)))
         (write-indent)
         (write-indicator "---" #t)
         (when canonical
           (write-indent)))
       (set! state expect-document-root)]
      [(stream-end-event? event)
       (when open-ended
         (write-indicator "..." #t)
         (write-indent))
       (write-stream-end)
       (set! state expect-nothing)]
      [else
       (emitter-error
        (format "expected document-start, but got ~a"
                (event->string event)))]))

  (define (expect-document-end)
    (cond
     [(document-end-event? event)
      (write-indent)
      (when (document-end-event-explicit event)
        (write-indicator "..." #t)
        (write-indent))
      (flush-stream)
      (set! state expect-document-start)]
     [else
      (emitter-error
       (format "expected document-end, but got ~a"
               (event->string event)))]))

  (define (expect-document-root)
    (append! states (list expect-document-end))
    (expect-node #t #f #f #f))

  ;; Node handlers.

  (define (expect-node [root #f] [sequence #f] [mapping #f] [simple-key #f])
    (set! root-context root)
    (set! sequence-context sequence)
    (set! mapping-context mapping)
    (set! simple-key-context simple-key)
    (cond
      [(alias-event? event)
       (expect-alias)]
      [(or (scalar-event? event)
           (collection-start-event? event))
       (process-anchor "&")
       (process-tag)
       (cond
         [(scalar-event? event)
          (expect-scalar)]
         [(sequence-start-event? event)
          (if (or (> flow-level 0)
                  canonical
                  (sequence-start-event-flow-style event)
                  (check-empty-sequence?))
              (expect-flow-sequence)
              (expect-block-sequence))]
         [(mapping-start-event? event)
          (if (or (> flow-level 0)
                  canonical
                  (mapping-start-event-flow-style event)
                  (check-empty-mapping?))
              (expect-flow-mapping)
              (expect-block-mapping))])]
      [else
       (emitter-error
        (format "expected node, but got ~a"
                (event->string event)))]))

  (define (expect-alias)
    (unless (alias-event-anchor event)
      (emitter-error "anchor is not specified for alias"))
    (process-anchor "*")
    (set! state (pop! states)))

  (define (expect-scalar)
    (increase-indent #t)
    (process-scalar)
    (set! indent (pop! indents))
    (set! state (pop! states)))

  ;; Flow sequence handlers.

  (define (expect-flow-sequence)
    (write-indicator "[" #t #t)
    (set! flow-level (add1 flow-level))
    (increase-indent #t)
    (set! state expect-first-flow-sequence-item))

  (define (expect-first-flow-sequence-item)
    (cond
     [(sequence-end-event? event)
      (set! indent (pop! indents))
      (set! flow-level (sub1 flow-level))
      (write-indicator "]" #f)
      (set! state (pop! states))]
     [else
      (when (or canonical (> column best-width))
        (write-indent))
      (append! states (list expect-flow-sequence-item))
      (expect-node #f #t #f #f)]))

  (define (expect-flow-sequence-item)
    (cond
     [(sequence-end-event? event)
      (set! indent (pop! indents))
      (set! flow-level (sub1 flow-level))
      (when canonical
        (write-indicator "," #f)
        (write-indent))
      (write-indicator "]" #f)
      (set! state (pop! states))]
     [else
      (write-indicator "," #f)
      (when (or canonical (> column best-width))
        (write-indent))
      (append! states (list expect-flow-sequence-item))
      (expect-node #f #t #f #f)]))

  ;; Flow mapping handlers.

  (define (expect-flow-mapping)
    (write-indicator "{" #t #t)
    (set! flow-level (add1 flow-level))
    (increase-indent #t)
    (set! state expect-first-flow-mapping-key))

  (define (expect-first-flow-mapping-key)
    (cond
     [(mapping-end-event? event)
      (set! indent (pop! indents))
      (set! flow-level (sub1 flow-level))
      (write-indicator "}" #f)
      (set! state (pop! states))]
     [else
       (when (or canonical (> column best-width))
         (write-indent))
       (cond
        [(and (not canonical) (check-simple-key?))
         (append! states (list expect-flow-mapping-simple-value))
         (expect-node #f #f #t #t)]
        [else
         (write-indicator "?" #t)
         (append! states (list expect-flow-mapping-value))
         (expect-node #f #f #t #f)])]))

  (define (expect-flow-mapping-key)
    (cond
     [(mapping-end-event? event)
      (set! indent (pop! indents))
      (set! flow-level (sub1 flow-level))
      (when canonical
        (write-indicator "," #f)
        (write-indent))
      (write-indicator "}" #f)
      (set! state (pop! states))]
     [else
      (write-indicator "," #f)
      (when (or canonical (> column best-width))
        (write-indent))
      (cond
       [(and (not canonical) (check-simple-key?))
        (append! states (list expect-flow-mapping-simple-value))
        (expect-node #f #f #t #t)]
       [else
        (write-indicator "?" #t)
        (append! states (list expect-flow-mapping-value))
        (expect-node #f #f #t #f)])]))

  (define (expect-flow-mapping-simple-value)
    (write-indicator ":" #f)
    (append! states (list expect-flow-mapping-key))
    (expect-node #f #f #t #f))

  (define (expect-flow-mapping-value)
    (when (or canonical (> column best-width))
      (write-indent))
    (write-indicator ":" #t)
    (append! states (list expect-flow-mapping-key))
    (expect-node #f #f #t #f))

  ;; Block sequence handlers.

  (define (expect-block-sequence)
    (increase-indent #f (and mapping-context (not indention)))
    (set! state expect-first-block-sequence-item))

  (define (expect-first-block-sequence-item)
    (expect-block-sequence-item #t))

  (define (expect-block-sequence-item [first #f])
    (cond
     [(and (not first) (sequence-end-event? event))
      (set! indent (pop! indents))
      (set! state (pop! states))]
     [else
      (write-indent)
      (write-indicator "-" #t #f #t)
      (append! states (list expect-block-sequence-item))
      (expect-node #f #t #f #f)]))

  ;; Block mapping handlers.

  (define (expect-block-mapping)
    (increase-indent #f)
    (set! state expect-first-block-mapping-key))

  (define (expect-first-block-mapping-key)
    (expect-block-mapping-key #t))

  (define (expect-block-mapping-key [first #f])
    (cond
     [(and (not first) (mapping-end-event? event))
      (set! indent (pop! indents))
      (set! state (pop! states))]
     [else
      (write-indent)
      (cond
       [(check-simple-key?)
        (append! states (list expect-block-mapping-simple-value))
        (expect-node #f #f #t #t)]
       [else
        (write-indicator "?" #t #f #t)
        (append! states (list expect-block-mapping-value))
        (expect-node #f #f #t #f)])]))

  (define (expect-block-mapping-simple-value)
    (write-indicator ":" #f)
    (append! states (list expect-block-mapping-key))
    (expect-node #f #f #t #f))

  (define (expect-block-mapping-value)
    (write-indent)
    (write-indicator ":" #t #f #t)
    (append! states (list expect-block-mapping-key))
    (expect-node #f #f #t #f))
  
  ;; Checkers.
  ;;  (expect-node [root #f] [sequence #f] [mapping #f] [simple-key #f])

  (define (check-empty-sequence?)
    (and (sequence-start-event? event)
         (not (null? events))
         (sequence-end-event? (car events))))

  (define (check-empty-mapping?)
    (and (mapping-start-event? event)
         (not (null? events))
         (mapping-end-event? (car events))))

  (define (check-empty-document?)
    (and (document-start-event? event)
         (not (null? events))
         (let ([e (car events)])
           (and (scalar-event? e)
                (not (scalar-event-anchor e))
                (not (scalar-event-tag e))
                (scalar-event-implicit e)
                (equal? "" (scalar-event-value e))))))

  (define (check-simple-key?)
    (let ([len 0])
      (when (and (node-event? event)
                 (node-event-anchor event))
        (unless prepared-anchor
          (set! prepared-anchor
                (prepare-anchor (node-event-anchor event))))
        (set! len (+ len (string-length prepared-anchor))))
      (when (and (or (scalar-event? event)
                     (collection-start-event? event))
                 (any-event-tag event))
        (unless prepared-tag
          (set! prepared-tag
                (prepare-tag (any-event-tag event))))
        (set! len (+ len (string-length prepared-tag))))
      (when (scalar-event? event)
        (unless analysis
          (set! analysis (analyze-scalar (scalar-event-value event))))
        (set! len (+ len (string-length (scalar-analysis-scalar analysis)))))
      (or (and (< len 128)
               (alias-event? event))
          (and (scalar-event? event)
               (not (scalar-analysis-empty analysis))
               (not (scalar-analysis-multiline analysis)))
          (check-empty-sequence?)
          (check-empty-mapping?))))

  ;; Anchor, Tag, and Scalar processors.

  (define (process-anchor indicator)
    (cond
     [(not (any-event-anchor event))
      (set! prepared-anchor #f)]
     [else
      (unless prepared-anchor
        (set! prepared-anchor
              (prepare-anchor (any-event-anchor event))))
      (when prepared-anchor
        (write-indicator (format "~a~a" indicator prepared-anchor) #t))
      (set! prepared-anchor #f)]))

  (define (process-tag)
    (let ([tag (any-event-tag event)])
      (when (and (scalar-event? event)
                 (not style))
        (set! style (choose-scalar-style)))
      (cond
       [(and (scalar-event? event)
             (or (not canonical) (not tag))
             (or (and (equal? "" style)
                      (car (scalar-event-implicit event)))
                 (and (not (equal? "" style))
                      (cdr (scalar-event-implicit event)))))
        (set! prepared-tag #f)]
       [(and (not (scalar-event? event))
             (or (not canonical)
                 (not tag))
             (collection-start-event-implicit event))
        (set! prepared-tag #f)]
       [else
        (when (and (scalar-event? event)
                   (car (scalar-event-implicit event))
                   (not tag))
          (set! tag "!")
          (set! prepared-tag #f))
        (unless tag
          (emitter-error "tag is not specified"))
        (unless prepared-tag
          (set! prepared-tag (prepare-tag tag)))
        (when prepared-tag
          (write-indicator prepared-tag #t))
        (set! prepared-tag #f)])))

  (define (choose-scalar-style)
    (unless analysis
      (set! analysis (analyze-scalar (scalar-event-value event))))
    (cond
     [(or (equal? #\" (scalar-event-style event)) canonical)
      #\"]
     [(and (not (scalar-event-style event))
           (car (scalar-event-implicit event))
           (not (and simple-key-context
                     (or (scalar-analysis-empty analysis)
                         (scalar-analysis-multiline analysis))))
           (or (and (> flow-level 0)
                    (scalar-analysis-allow-flow-plain analysis))
               (and (= flow-level 0)
                    (scalar-analysis-allow-block-plain analysis))))
      ""]
     [(and (scalar-event-style event)
           (member (scalar-event-style event) '(#\| #\>))
           (zero? flow-level)
           (not simple-key-context)
           (scalar-analysis-allow-block analysis))
      (scalar-event-style event)]
     [(and (or (not (scalar-event-style event))
               (char=? #\' (scalar-event-style event)))
           (scalar-analysis-allow-single-quoted analysis)
           (not (and simple-key-context
                     (scalar-analysis-multiline analysis))))
      #\']
     [else
      #\"]))

  (define (process-scalar)
    (unless analysis
      (set! analysis (analyze-scalar (scalar-event-value event))))
    (unless style
      (set! style (not simple-key-context)))
    (let ([split (not simple-key-context)])
      (cond
       [(equal? #\" style)
        (write-double-quoted (scalar-analysis-scalar analysis) split)]
       [(equal? #\' style)
        (write-single-quoted (scalar-analysis-scalar analysis) split)]
       [(equal? #\> style)
        (write-folded (scalar-analysis-scalar analysis))]
       [(equal? #\| style)
        (write-literal (scalar-analysis-scalar analysis))]
       [else
        (write-plain (scalar-analysis-scalar analysis) split)])
      (set! analysis #f)
      (set! style #f)))

  ;; Analyzers.

  (define (prepare-version version)
    (match-let ([(cons major minor) version])
      (unless (= 1 major)
        (emitter-error
         (format "unsupported YAML version: ~a.~a" major minor)))
      (format "~a.~a" major minor)))

  (define (prepare-tag-handle handle)
    (unless (> (string-length handle) 0)
      (emitter-error "tag handle must not be empty"))
    (let ([cs (string->list handle)])
      (unless (and (char=? #\! (car cs))
                   (char=? #\! (last cs)))
        (emitter-error
         (format "tag handle must start and end with '!': ~a" handle)))
      (when (> (string-length handle) 1)
        (for ([ch (substring handle 1 (sub1 (string-length handle)))])
          (unless (or (char<=? #\0 ch #\9)
                      (char<=? #\A ch #\Z)
                      (char<=? #\a ch #\z)
                      (char=? #\- ch)
                      (char=? #\_ ch))
            (emitter-error
             (format
              "invalid character ~a in the tag handle: ~a" ch handle)))))
      handle))

  (define (prepare-tag-prefix prefix)
    (unless (> (string-length prefix) 0)
      (emitter-error "tag prefix must not be empty"))
    (let ([chunks '()]
          [start 0]
          [end 0])
      (when (char=? #\! (string-ref prefix 0))
        (set! end 1))
      (while (< end (string-length prefix))
        (let ([ch (string-ref prefix end)])
          (cond
           [(or (char<=? #\0 ch #\9)
                (char<=? #\A ch #\Z)
                (char<=? #\a ch #\z)
                (string-index "-;/?!:@&=+$,_.~*'()[]" ch))
            (set! end (add1 end))]
           [else
            (when (< start end)
              (append! chunks (list (substring prefix start end))))
            (set! start (add1 end))
            (set! end (add1 end))
            (append! chunks (list (format "~a" ch)))])))
      (when (< start end)
        (append! chunks (list (substring prefix start end))))
      (apply string-append chunks)))

  (define (prepare-tag tag)
    (unless (and (string? tag) (> (string-length tag) 0))
      (emitter-error "tag must not be empty"))
    (if (string=? "!" tag)
        tag
        (let ([handle #f]
              [suffix tag])
          (for ([prefix (sort (hash-keys tag-prefixes) string<?)])
            (when (and (string-prefix? prefix tag)
                       (or (string=? "!" prefix)
                           (< (string-length prefix)
                              (string-length tag))))
              (set! handle (hash-ref tag-prefixes prefix))
              (set! suffix (substring tag (string-length prefix)))))
          (let ([chunks '()]
                [start 0]
                [end 0])
            (while (< end (string-length suffix))
              (let ([ch (string-ref suffix end)])
                (cond
                 [(or (char<=? #\0 ch #\9)
                      (char<=? #\A ch #\Z)
                      (char<=? #\a ch #\z)
                      (string-index "-;/?!:@&=+$,_.~*'()[]" ch))
                  (set! end (add1 end))]
                 [else
                  (when (< start end)
                    (append! chunks (list (substring suffix start end))))
                  (set! start (add1 end))
                  (set! end (add1 end))
                  (append! chunks (list (format "~a" ch)))])))
            (when (< start end)
              (append! chunks (list (substring suffix start end))))
            (if (and (string? handle) (> (string-length handle) 0))
                (format "~a~a" handle (apply string-append chunks))
                (format "!<~a>" (apply string-append chunks)))))))

  (define (prepare-anchor anchor)
    (unless (> (string-length anchor) 0)
      (emitter-error "anchor must not be empty"))
    (for ([ch anchor])
      (unless (or (char<=? #\0 ch #\9)
                  (char<=? #\A ch #\Z)
                  (char<=? #\a ch #\z)
                  (char=? #\- ch)
                  (char=? #\_ ch))
        (emitter-error
         (format "invalid character ~a in the anchor: ~a" ch anchor))))
    anchor)

  (define (analyze-scalar scalar)
    (cond
     [(string=? "" scalar)
      (scalar-analysis scalar #t #f #f #t #t #t #f)]
     [else
      (let ([block-indicators #f]
            [flow-indicators #f]
            [line-breaks #f]
            [special-characters #f]
            [leading-space #f]
            [leading-break #f]
            [trailing-space #f]
            [trailing-break #f]
            [break-space #f]
            [space-break #f]
            [preceeded-by-whitespace #t]
            [followed-by-whitespace
             (or (= 1 (string-length scalar))
                 (string-index "\0 \t\r\n\x85\u2028\u2029"
                               (string-ref scalar 1)))]
            [previous-space #f]
            [previous-break #f]
            [index 0]
            [allow-flow-plain #t]
            [allow-block-plain #t]
            [allow-single-quoted #t]
            [allow-double-quoted #t]
            [allow-block #t])
        (when (or (string-prefix? "---" scalar)
                  (string-prefix? "..." scalar))
          (set! block-indicators #t)
          (set! flow-indicators #t))
        (while (< index (string-length scalar))
          (let ([ch (string-ref scalar index)])
            (cond
             [(zero? index)
              (when (string-index "#,[]{}&*!|>'\"%@`" ch)
                (set! flow-indicators #t)
                (set! block-indicators #t))
              (when (string-index "?:" ch)
                (set! flow-indicators #t)
                (when followed-by-whitespace
                  (set! block-indicators #t)))
              (when (and (char=? #\- ch) followed-by-whitespace)
                (set! flow-indicators #t)
                (set! block-indicators #t))]
             [else
              (when (string-index ",?[]{}" ch)
                (set! flow-indicators #t))
              (when (char=? #\: ch)
                (set! flow-indicators #t)
                (when followed-by-whitespace
                  (set! block-indicators #t)))
              (when (and (char=? #\# ch) preceeded-by-whitespace)
                (set! flow-indicators #t)
                (set! block-indicators #t))])
            (when (string-index "\n\x85\u2028\u2029" ch)
              (set! line-breaks #t))
            (unless (or (char=? #\newline ch)
                        (char<=? #\space ch #\~))
              (cond
               [(and (or (char=? #\u0085 ch)
                         (char<=? #\u00A0 ch #\uD7FF)
                         (char<=? #\uE000 ch #\uFFFD))
                     (not (char=? #\uFEFF ch)))
                (unless allow-unicode
                  (set! special-characters #t))]
               [else (set! special-characters #t)]))
            (cond
             [(char=? #\space ch)
              (when (zero? index)
                (set! leading-space #t))
              (when (= index (- (string-length scalar) 1))
                (set! trailing-space #t))
              (when previous-break
                (set! break-space #t))
              (set! previous-space #t)
              (set! previous-break #t)]
             [(string-index "\n\x85\u2028\u2029" ch)
              (when (zero? index)
                (set! leading-break #t))
              (when (= index (- (string-length scalar) 1))
                (set! trailing-break #t))
              (when previous-space
                (set! space-break #t))
              (set! previous-space #f)
              (set! previous-break #t)]
             [else
              (set! previous-space #f)
              (set! previous-break #f)])
            (set! index (add1 index))
            (set! preceeded-by-whitespace
                  (string-index "\0 \t\r\n\x85\u2028\u2029" ch))
            (set! followed-by-whitespace
                  (or (>= (+ 1 index) (string-length scalar))
                      (string-index "\0 \t\r\n\x85\u2028\u2029"
                                    (string-ref scalar (+ index 1)))))))
        (when (or leading-space leading-break
                  trailing-space trailing-break)
          (set! allow-flow-plain #f)
          (set! allow-block-plain #f))
        (when trailing-space
          (set! allow-block #f))
        (when break-space
          (set! allow-flow-plain #f)
          (set! allow-block-plain #f)
          (set! allow-single-quoted #f))
        (when (or space-break special-characters)
          (set! allow-flow-plain #f)
          (set! allow-block-plain #f)
          (set! allow-single-quoted #f)
          (set! allow-block #f))
        (when line-breaks
          (set! allow-flow-plain #f)
          (set! allow-block-plain #f))
        (when flow-indicators
          (set! allow-flow-plain #f))
        (when block-indicators
          (set! allow-block-plain #f))
        (scalar-analysis
         scalar #f line-breaks allow-flow-plain allow-block-plain
         allow-single-quoted allow-double-quoted allow-block))]))
        
  ;; Writers.

  (define (flush-stream)
    (flush-output out))

  (define (write-stream-start)
    ;; no encoding here
    #f)

  (define (write-stream-end)
    (flush-stream))

  (define (write-indicator indicator need-whitespace
                           [write-whitespace #f] [write-indention #f])
    (let ([data (if (or whitespace (not need-whitespace))
                    indicator
                    (format " ~a" indicator))])
      (set! whitespace write-whitespace)
      (set! indention (and indention write-indention))
      (set! column (+ column (string-length data)))
      (set! open-ended #f)
      (fprintf out data)))

  (define (write-indent)
    (let ([indent (or indent 0)])
      (when (or (not indention) (> column indent)
                (and (= column indent) (not whitespace)))
        (write-line-break))
      (when (< column indent)
        (let ([n (- indent column)])
          (set! whitespace #t)
          (set! column indent)
          (fprintf out (list->string (build-list n (λ _ #\space))))))))

  (define (write-line-break [data #f])
    (when (char? data)
      (set! data (string data)))
    (unless data
      (set! data best-line-break))
    (set! whitespace #t)
    (set! indention #t)
    (set! line (add1 line))
    (set! column 0)
    (fprintf out data))

  (define (write-version-directive version-text)
    (fprintf out (format "%YAML ~a" version-text))
    (write-line-break))

  (define (write-tag-directive handle-text prefix-text)
    (fprintf out (format "%TAG ~a ~a" handle-text prefix-text))
    (write-line-break))

  ;; Scalar streams.

  (define (write-single-quoted text [split #t])
    (write-indicator "'" #t)
    (let ([spaces #f]
          [breaks #f]
          [start 0]
          [end 0])
      (while (<= end (string-length text))
        (let ([ch #f])
          (when (< end (string-length text))
            (set! ch (string-ref text end)))
          (cond
           [spaces
            (unless (char=? #\space ch)
              (if (and (= (+ 1 start) end)
                       (> column best-width)
                       split
                       (not (zero? start))
                       (not (= end (string-length text))))
                  (write-indent)
                  (let ([data (substring text start end)])
                    (set! column (+ column (string-length data)))
                    (fprintf out data)))
              (set! start end))]
           [breaks
            (unless (and (char? ch) (string-index "\n\x85\u2028\u2029" ch))
              (when (char=? (string-ref text start) #\newline)
                (write-line-break))
              (for ([br (substring text start end)])
                (if (char=? br #\newline)
                    (write-line-break)
                    (write-line-break br)))
              (write-indent)
              (set! start end))]
           [else
            (when (or (not (char? ch))
                      (string-index " \n\x85\u2028\u2029" ch)
                      (char=? #\' ch))
              (when (< start end)
                (let ([data (substring text start end)])
                  (set! column (+ column (string-length data)))
                  (fprintf out data)
                  (set! start end))))])
          (when (equal? #\' ch)
            (set! column (+ column 2))
            (fprintf out "''")
            (set! start (add1 end)))
          (when (char? ch)
            (set! spaces (char=? #\space ch))
            (set! breaks (string-index "\n\x85\u2028\u2029" ch)))
          (set! end (add1 end))))
      (write-indicator "'" #f)))

  (define (write-double-quoted text [split #t])
    (define ESCAPE-REPLACEMENTS
      #hash((#\nul . #\0)
            (#\u0007 . #\a)
            (#\backspace . #\b)
            (#\tab . #\t)
            (#\newline . #\n)
            (#\vtab . #\v)
            (#\page . #\f)
            (#\return . #\r)
            (#\u001B . #\e)
            (#\" . #\")
            (#\\ . #\\)
            (#\u0085 . #\N)
            (#\u00A0 . #\_)
            (#\u2028 . #\L)
            (#\u2029 . #\P)))
    (let ([start 0] [end 0])
      (write-indicator "\"" #t)
      (while (<= end (string-length text))
        (let ([ch #f])
          (when (< end (string-length text))
            (set! ch (string-ref text end)))
          (when (or (not (char? ch))
                    (string-index "\"\\\x85\u2028\u2029\uFEFF" ch)
                    (not (char<=? #\space ch #\~))
                    (and allow-unicode
                         (or (char<=? #\u00A0 ch #\uD7FF)
                             (char<=? #\uE000 ch #\uFFFD))))
            (when (< start end)
              (let ([data (substring text start end)])
                (set! column (+ column (string-length data)))
                (fprintf out data)
                (set! start end)))
            (when (char? ch)
              (let ([data ""])
                (cond
                 [(hash-has-key? ESCAPE-REPLACEMENTS ch)
                  (let ([esc (hash-ref ESCAPE-REPLACEMENTS ch)])
                    (set! data (format "\\~a" esc)))]
                 [(char<=? ch #\u00FF)
                  (let ([hex (number->string (char->integer ch) 16)])
                    (set! data (format "\\x~a" (string-upcase hex))))]
                 [(char<=? ch #\uFFFF)
                  (let ([hex (number->string (char->integer ch) 16)])
                    (if (= 2 (string-length hex))
                        (set! data (format "\\u00~a" (string-upcase hex)))
                        (set! data (format "\\u~a" (string-upcase hex)))))]
                 [else
                  (let ([hex (number->string (char->integer ch) 16)])
                    (if (= 2 (string-length hex))
                        (set! data (format "\\U000000~a" (string-upcase hex)))
                        (set! data (format "\\U0000~a" (string-upcase hex)))))])
                (set! column (+ column (string-length data)))
                (fprintf out data)
                (set! start (add1 end)))))
          (when (and (< 0 end (sub1 (string-length text)))
                     (or (equal? #\space ch) (>= start end))
                     (> (+ column (- end start)) best-width)
                     split)
            (let ([data (string-append (substring text start end) "\\")])
              (when (< start end)
                (set! start end))
              (set! column (+ column (string-length data)))
              (fprintf out data)
              (write-indent)
              (set! whitespace #f)
              (set! indention #f)
              (when (char=? #\space (string-ref text start))
                (let ([data "\\"])
                  (set! column (+ column (string-length data)))
                  (fprintf out data)))))
          (set! end (add1 end))))
      (write-indicator "\"" #f)))

  (define (determine-block-hints text)
    (let ([hints ""])
      (when (and (string? text) (> (string-length text) 0))
        (when (string-index " \n\x85\u2028\u2029" (string-ref text 0))
          (set! hints (format "~a~a" hints best-indent)))
        (cond
         [(not (string-index "\n\x85\u2028\u2029"
                             (string-ref text (- (string-length text) 1))))
          (set! hints (string-append hints "-"))]
         [(or (= 1 (string-length text))
              (string-index "\n\x85\u2028\u2029"
                            (string-ref text (- (string-length text) 2))))
          (set! hints (string-append hints "+"))]))
      hints))

  (define (write-folded text)
    (let ([hints (determine-block-hints text)]
          [leading-space #t]
          [spaces #f]
          [breaks #t]
          [start 0]
          [end 0])
      (write-indicator (string-append ">" hints) #t)
      (when (and (> (string-length hints) 0)
                 (char=? #\+ (string-ref hints
                                         (sub1 (string-length hints)))))
        (set! open-ended #t))
      (write-line-break)
      (while (<= end (string-length text))
        (let ([ch #f])
          (when (< end (string-length text))
            (set! ch (string-ref text end)))
          (cond
           [breaks
            (unless (and (char? ch)
                         (string-index "\n\x85\u2028\u2029" ch))
              (when (and (not leading-space)
                         (char? ch)
                         (not (char=? #\space ch))
                         (char=? #\newline (string-ref text start)))
                (write-line-break))
              (set! leading-space (equal? #\space ch))
              (for ([br (substring text start end)])
                (if (char=? #\newline br)
                    (write-line-break)
                    (write-line-break br)))
              (when (char? ch)
                (write-indent))
              (set! start end))]
           [spaces
            (unless (and (char? ch)
                         (char=? #\space ch))
              (if (and (= (add1 start) end) (> column best-width))
                  (write-indent)
                  (let ([data (substring text start end)])
                    (set! column (+ column (string-length data)))
                    (fprintf out data)))
              (set! start end))]
           [else
            (when (or (not (char? ch))
                      (string-index "\n\x85\u2028\u2029" ch))
              (let ([data (substring text start end)])
                (set! column (+ column (string-length data)))
                (fprintf out data)
                (unless (char? ch)
                  (write-line-break))
                (set! start end)))])
          (when (char? ch)
            (set! breaks (string-index "\n\x85\u2028\u2029" ch))
            (set! spaces (char=? #\space ch)))
          (set! end (add1 end))))))

  (define (write-literal text)
    (let ([hints (determine-block-hints text)]
          [breaks #t]
          [start 0]
          [end 0])
      (write-indicator (string-append "|" hints) #t)
      (when (and (> (string-length hints) 0)
                 (char=? #\+ (string-ref hints
                                         (sub1 (string-length hints)))))
        (set! open-ended #t))
      (write-line-break)
      (while (<= end (string-length text))
        (let ([ch #f])
          (when (< end (string-length text))
            (set! ch (string-ref text end)))
          (when breaks
             (when (or (not (char? ch))
                       (not (string-index "\n\x85\u2028\u2029" ch)))
               (for ([br (substring text start end)])
                 (if (char=? #\newline br)
                     (write-line-break)
                     (write-line-break br)))
               (when (char? ch)
                 (write-indent))
               (set! start end)))
          (unless breaks
            (when (or (not (char? ch))
                      (string-index "\n\x85\u2028\u2029" ch))
              (fprintf out (substring text start end))
              (unless (char? ch)
                (write-line-break))
              (set! start end)))
          (when (char? ch)
            (set! breaks (string-index "\n\x85\u2028\u2029" ch)))
          (set! end (add1 end))))))

  (define (write-plain text [split #t])
    (when root-context
      (set! open-ended #t))
    (when (> (string-length text) 0)
      (let ([spaces #f]
            [breaks #f]
            [start 0]
            [end 0])
        (unless whitespace
          (let ([data " "])
            (set! column (+ column (string-length data)))
            (fprintf out data)))
        (set! whitespace #f)
        (set! indention #f)
        (while (<= end (string-length text))
          (let ([ch #f])
            (when (< end (string-length text))
              (set! ch (string-ref text end)))
            (cond
             [spaces
              (unless (equal? #\space ch)
                (cond
                 [(and (= (add1 start) end)
                       (> column best-width)
                       split)
                  (write-indent)
                  (set! whitespace #f)
                  (set! indention #f)]
                 [else
                  (let ([data (substring text start end)])
                    (set! column (+ column (string-length data)))
                    (fprintf out data))])
                (set! start end))]
             [breaks
              (unless (and (char? ch)
                           (string-index "\n\x85\u2028\u2029" ch))
                (when (char=? #\newline (string-ref text start))
                  (write-line-break))
                (for ([br (substring text start end)])
                  (if (char=? #\newline br)
                      (write-line-break)
                      (write-line-break br)))
                (write-indent)
                (set! whitespace #f)
                (set! indention #f)
                (set! start end))]
             [else
              (unless (and (char? ch)
                           (string-index "\n\x85\u2028\u2029" ch))
                (let ([data (substring text start end)])
                  (set! column (+ column (string-length data)))
                  (fprintf out data)
                  (set! start end)))])
            (when (char? ch)
              (set! spaces (char=? #\space ch))
              (set! breaks (string-index "\n\x85\u2028\u2029" ch)))
            (set! end (add1 end)))))))

  (values emit))

(module+ test
  (require rackunit racket/generator "parser.rkt")
  (define-simple-check (check-emitter test-file check-file)
    (let* ([out (open-output-string)]
           [in (open-input-file check-file)]
           [emit (make-emitter out)])
      (for ([event (parse-file test-file)])
        (emit event))
      (check-equal? (get-output-string out) (port->string in))
      (close-output-port out)
      (close-input-port in)))
  (test-begin
   (for ([(test-file check-file) (test-files #"emit")])
     (check-emitter test-file check-file))))