#lang racket/base
;; Preserve, as in Fruit Preserve, as in a remarkably weak pun on pickling/dehydration etc

(provide (struct-out stream-of)
         (struct-out record)
         short-form-labels
         read-preserve
         string->preserve
         encode
         decode
         wire-value)

(require racket/bytes)
(require racket/dict)
(require racket/generator)
(require racket/match)
(require racket/set)
(require bitsyntax)
(require syndicate/support/struct)
(require (only-in syntax/readerr raise-read-error))

(require imperative-syndicate/assertions)
(require imperative-syndicate/pattern)

(struct stream-of (kind generator) #:transparent)

(struct record (label fields) #:transparent)

(define short-form-labels
  (make-parameter (vector 'discard 'capture 'observe)))

(define (encode v)
  (bit-string->bytes (bit-string (v :: (wire-value)))))

(define (decode bs [on-fail (lambda () (error 'decode "Invalid encoding: ~v" bs))])
  (bit-string-case bs
    ([ (v :: (wire-value)) ] v)
    (else (on-fail))))

(define-syntax wire-value
  (syntax-rules ()
    [(_ #t input ks kf) (decode-value input ks kf)]
    [(_ #f v) (encode-value v)]))

(define-syntax wire-length
  (syntax-rules ()
    [(_ #t input ks kf) (decode-wire-length input ks kf)]
    [(_ #f v) (encode-wire-length v)]))

(define (encode-wire-length v)
  (when (negative? v) (error 'encode-wire-length "Cannot encode negative wire-length ~v" v))
  (if (< v #b1111)
      (bit-string (v :: bits 4))
      (bit-string (#b1111 :: bits 4) ((encode-varint v) :: binary))))

(define (encode-varint v)
  (if (< v 128)
      (bytes v)
      (bit-string ((+ (modulo v 128) 128) :: bits 8)
                  ((encode-varint (quotient v 128)) :: binary))))

(define (encode-array-like major minor fields)
  (bit-string (major :: bits 2)
              (minor :: bits 2)
              ((length fields) :: (wire-length))
              ((apply bit-string-append (map encode-value fields)) :: binary)))

(define (encode-binary-like major minor bs)
  (bit-string (major :: bits 2)
              (minor :: bits 2)
              ((bytes-length bs) :: (wire-length))
              (bs :: binary)))

(define (encode-start-byte major minor)
  (bit-string (#b0010 :: bits 4) (major :: bits 2) (minor :: bits 2)))

(define (encode-end-byte major minor)
  (bit-string (#b0011 :: bits 4) (major :: bits 2) (minor :: bits 2)))

(define (encode-stream major minor chunk-ok? generator)
  (bit-string-append (encode-start-byte major minor)
                     (let loop ()
                       (match (generator)
                         [(? void?) #""]
                         [(? chunk-ok? v) (bit-string-append (encode-value v) (loop))]
                         [bad (error 'encode-stream "Cannot encode chunk: ~v" bad)]))
                     (encode-end-byte major minor)))

(define (dict-keys-and-values d)
  (reverse (for/fold [(acc '())] [((k v) (in-dict d))] (cons v (cons k acc)))))

(define (short-form-for-label key)
  (let ((labels (short-form-labels)))
    (let loop ((i 0))
      (cond [(= i 3) #f]
            [(equal? (vector-ref labels i) key) i]
            [else (loop (+ i 1))]))))

(define (encode-record key fields)
  (define short (short-form-for-label key))
  (if short
      (encode-array-like 2 short fields)
      (encode-array-like 2 3 (cons key fields))))

(define (encode-value v)
  (match v
    [#f (bytes #b00000000)]
    [#t (bytes #b00000001)]
    [(? single-flonum?) (bit-string #b00000010 (v :: float bits 32))]
    [(? double-flonum?) (bit-string #b00000011 (v :: float bits 64))]
    [(? integer? x) #:when (<= -3 x 12) (bit-string (#b0001 :: bits 4) (x :: bits 4))]
    [(stream-of 'string p)      (encode-stream 1 1 bytes? p)]
    [(stream-of 'byte-string p) (encode-stream 1 2 bytes? p)]
    [(stream-of 'symbol p)      (encode-stream 1 3 bytes? p)]
    [(stream-of 'sequence p)    (encode-stream 3 0 (lambda (x) #t) p)]
    [(stream-of 'set p)         (encode-stream 3 1 (lambda (x) #t) p)]
    [(stream-of 'dictionary p)  (encode-stream 3 2 (lambda (x) #t) p)]

    ;; [0 (bytes #b10000000)]
    [(? integer?)
     (define raw-bit-count (+ (integer-length v) 1)) ;; at least one sign bit
     (define byte-count (quotient (+ raw-bit-count 7) 8))
     (bit-string (#b0100 :: bits 4) (byte-count :: (wire-length)) (v :: integer bytes byte-count))]
    [(? string?) (encode-binary-like 1 1 (string->bytes/utf-8 v))]
    [(? bytes?)  (encode-binary-like 1 2 v)]
    [(? symbol?) (encode-binary-like 1 3 (string->bytes/utf-8 (symbol->string v)))]

    [(record label fields) (encode-record label fields)]
    [(? non-object-struct?)
     (define key (prefab-struct-key v))
     (when (not key) (error 'encode-value "Cannot encode non-prefab struct ~v" v))
     (encode-record key (cdr (vector->list (struct->vector v))))]

    [(? list?)   (encode-array-like 3 0 v)]
    [(? set?)    (encode-array-like 3 1 (set->list v))]
    [(? dict?)   (encode-array-like 3 2 (dict-keys-and-values v))]

    [_ (error 'encode-value "Cannot encode value ~v" v)]))

;;---------------------------------------------------------------------------

(define (decode-wire-length bs ks kf)
  (bit-string-case bs
    ([ (= #b1111 :: bits 4) (rest :: binary) ]
     (decode-varint rest
                    (lambda (v tail)
                      (if (< v #b1111)
                          (kf)
                          (ks v tail)))
                    kf))
    ([ (v :: bits 4) (rest :: binary) ] (ks v rest))
    (else (kf))))

(define (decode-varint bs ks kf)
  (bit-string-case bs
    ([ (= 1 :: bits 1) (v :: bits 7) (rest :: binary) ]
     (decode-varint rest (lambda (acc tail) (ks (+ (* acc 128) v) tail)) kf))
    ([ (= 0 :: bits 1) (v :: bits 7) (rest :: binary) ]
     (ks v rest))
    (else
     (kf))))

(define (decode-values n acc-rev bs ks kf)
  (if (zero? n)
      (ks (reverse acc-rev) bs)
      (bit-string-case bs
        ([ (v :: (wire-value)) (rest :: binary) ]
         (decode-values (- n 1) (cons v acc-rev) rest ks kf))
        (else (kf)))))

(define (decode-binary minor bs rest ks kf)
  (match minor
    [0 (if (positive? (bit-string-length bs))
           (ks (bit-string->signed-integer bs #t) rest)
           (ks 0 rest))]
    [2 (ks bs rest)]
    [(or 1 3)
     ((with-handlers [(exn:fail:contract? (lambda (e) kf))]
        (define s (bytes->string/utf-8 bs))
        (lambda () (ks (if (= minor 3) (string->symbol s) s) rest))))]))

(define (build-record label fields)
  (with-handlers [(exn:fail:contract? (lambda (e) (record label fields)))]
    (apply make-prefab-struct label fields)))

(define (decode-record minor fields rest ks kf)
  (match* (minor fields)
    [(3 (list* key fs)) (ks (build-record key fs) rest)]
    [(3 '()) (kf)]
    [(n fs) (ks (build-record (vector-ref (short-form-labels) n) fs) rest)]))

(define (decode-collection minor vs rest ks kf)
  (match minor
    [0 (ks vs rest)]
    [1 (ks (list->set vs) rest)]
    [2 (if (even? (length vs))
           (ks (apply hash vs) rest)
           (kf))]
    [_ (kf)]))

(define (decode-stream major minor chunk-ok? join-chunks decode rest ks kf)
  (let loop ((acc-rev '()) (rest rest))
    (bit-string-case rest
      ([ (= #b0011 :: bits 4) (emajor :: bits 2) (eminor :: bits 2) (rest :: binary) ]
       (if (and (= major emajor) (= minor eminor))
           (decode minor (join-chunks (reverse acc-rev)) rest ks kf)
           (kf)))
      (else
       (decode-value rest
                     (lambda (chunk rest)
                       (if (chunk-ok? chunk)
                           (loop (cons chunk acc-rev) rest)
                           (kf)))
                     kf)))))

(define (decode-value bs ks kf)
  (bit-string-case bs
    ([ (= #b00000000 :: bits 8) (rest :: binary) ] (ks #f rest))
    ([ (= #b00000001 :: bits 8) (rest :: binary) ] (ks #t rest))
    ([ (= #b00000010 :: bits 8) (v :: float bits 32) (rest :: binary) ] (ks (real->single-flonum v) rest))
    ([ (= #b00000011 :: bits 8) (v :: float bits 64) (rest :: binary) ] (ks v rest))
    ([ (= #b0001 :: bits 4) (x :: bits 4) (rest :: binary) ] (ks (if (> x 12) (- x 16) x) rest))

    ([ (= #b001001 :: bits 6) (minor :: bits 2) (rest :: binary) ]
     (decode-stream 1 minor bytes? bytes-append* decode-binary rest ks kf))
    ([ (= #b001010 :: bits 6) (minor :: bits 2) (rest :: binary) ]
     (decode-stream 2 minor (lambda (x) #t) values decode-record rest ks kf))
    ([ (= #b001011 :: bits 6) (minor :: bits 2) (rest :: binary) ]
     (decode-stream 3 minor (lambda (x) #t) values decode-collection rest ks kf))

    ([ (= #b01 :: bits 2) (minor :: bits 2) (byte-count :: (wire-length))
       (bits :: binary bytes byte-count)
       (rest :: binary) ]
     (decode-binary minor (bit-string->bytes bits) rest ks kf))

    ([ (= #b10 :: bits 2) (minor :: bits 2) (field-count :: (wire-length)) (rest :: binary) ]
     (decode-values field-count '() rest
                    (lambda (fields rest) (decode-record minor fields rest ks kf))
                    kf))

    ([ (= #b11 :: bits 2) (minor :: bits 2) (count :: (wire-length)) (rest :: binary) ]
     (decode-values count '() rest
                    (lambda (vs rest) (decode-collection minor vs rest ks kf))
                    kf))

    (else (kf))))

;;---------------------------------------------------------------------------

(define (skip-whitespace* i)
  (regexp-match? #px#"^(\\s|,)*" i)
  (match (peek-char i)
    [#\; (regexp-match? #px#"[^\r\n]*[\r\n]" i) (skip-whitespace* i)]
    [_ #t]))

(define (parse-error* i fmt . args)
  (define-values [line column pos] (port-next-location i))
  (raise-read-error (format "read-preserve: ~a" (apply format fmt args))
                    (object-name i)
                    line
                    column
                    pos
                    #f))

(define (read-preserve [i (current-input-port)])
  (local-require net/base64)
  (local-require file/sha1)

  (define-match-expander px
    (syntax-rules ()
      [(_ re pat) (app (lambda (v) (regexp-try-match re v)) pat)]))

  (define (parse-error fmt . args)
    (apply parse-error* i fmt args))

  (define (eof-guard ch)
    (match ch
      [(? eof-object?) (parse-error "Unexpected end of input")]
      [ch ch]))

  (define (peek/no-eof) (eof-guard (peek-char i)))
  (define (read/no-eof) (eof-guard (read-char i)))

  (define (skip-whitespace) (skip-whitespace* i))

  (define (read-sequence terminator)
    (sequence-fold '() accumulate-value reverse terminator))

  (define (accumulate-value acc)
    (cons (read-value) acc))

  (define (read-dictionary-or-set)
    (sequence-fold #f
                   (lambda (acc)
                     (define k (read-value))
                     (skip-whitespace)
                     (match (peek-char i)
                       [#\: (when (set? acc) (parse-error "Unexpected key/value separator in set"))
                            (read-char i)
                            (define v (read-value))
                            (hash-set (or acc (hash)) k v)]
                       [_ (when (hash? acc) (parse-error "Missing expected key/value separator"))
                          (set-add (or acc (set)) k)]))
                   values
                   #\}))

  (define PIPE #\|)

  (define (read-raw-symbol acc)
    (match (peek-char i)
      [(or (? eof-object?)
           (? char? (or #\( #\) #\{ #\} #\[ #\]
                        #\" #\; #\, #\# #\: (== PIPE)
                        (? char-whitespace?))))
       (string->symbol (list->string (reverse acc)))]
      [_ (read-raw-symbol (cons (read-char i) acc))]))

  (define (read-base64-binary acc)
    (skip-whitespace)
    (define ch (read/no-eof))
    (cond [(eqv? ch #\})
           (base64-decode (string->bytes/latin-1 (list->string (reverse acc))))]
          [(or (and (char>=? ch #\A) (char<=? ch #\Z))
               (and (char>=? ch #\a) (char<=? ch #\z))
               (and (char>=? ch #\0) (char<=? ch #\9))
               (memv ch '(#\+ #\/ #\- #\_ #\=)))
           (read-base64-binary (cons ch acc))]
          [else
           (parse-error "Invalid base64 character")]))

  (define (hexdigit? ch)
    (or (and (char>=? ch #\A) (char<=? ch #\F))
        (and (char>=? ch #\a) (char<=? ch #\f))
        (and (char>=? ch #\0) (char<=? ch #\9))))

  (define (read-hex-binary acc)
    (skip-whitespace)
    (define ch (read/no-eof))
    (cond [(eqv? ch #\})
           (hex-string->bytes (list->string (reverse acc)))]
          [(hexdigit? ch)
           (define ch2 (read/no-eof))
           (when (not (hexdigit? ch2))
             (parse-error "Hex-encoded binary digits must come in pairs"))
           (read-hex-binary (cons ch2 (cons ch acc)))]
          [else
           (parse-error "Invalid hex character")]))

  (define (read-stringlike xform-item finish terminator-char hexescape-char hexescape-proc)
    (let loop ((acc '()))
      (match (read/no-eof)
        [(== terminator-char) (finish (reverse acc))]
        [#\\ (match (read/no-eof)
               [(== hexescape-char) (loop (cons (hexescape-proc) acc))]
               [(and c (or (== terminator-char) #\\ #\/)) (loop (cons (xform-item c) acc))]
               [#\b (loop (cons (xform-item #\u08) acc))]
               [#\f (loop (cons (xform-item #\u0C) acc))]
               [#\n (loop (cons (xform-item #\u0A) acc))]
               [#\r (loop (cons (xform-item #\u0D) acc))]
               [#\t (loop (cons (xform-item #\u09) acc))]
               [c (parse-error "Invalid escape code \\~a" c)])]
        [c (loop (cons (xform-item c) acc))])))

  (define (read-string terminator-char)
    (read-stringlike values
                     list->string
                     terminator-char
                     #\u
                     (lambda ()
                       (integer->char
                        (match i
                          [(px #px#"^[a-fA-F0-9]{4}" (list hexdigits))
                           (define n1 (string->number (bytes->string/utf-8 hexdigits) 16))
                           (if (<= #xd800 n1 #xdfff) ;; surrogate pair first half
                               (match i
                                 [(px #px#"^\\\\u([a-fA-F0-9]{4})" (list _ hexdigits2))
                                  (define n2 (string->number (bytes->string/utf-8 hexdigits2) 16))
                                  (if (<= #xdc00 n2 #xdfff)
                                      (+ (arithmetic-shift (- n1 #xd800) 10)
                                         (- n2 #xdc00)
                                         #x10000)
                                      (parse-error "Bad second half of surrogate pair"))]
                                 [_ (parse-error "Missing second half of surrogate pair")])
                               n1)]
                          [_ (parse-error "Bad string \\u escape")])))))

  (define (read-literal-binary)
    (read-stringlike (lambda (c)
                       (define b (char->integer c))
                       (when (>= b 256)
                         (parse-error "Invalid code point ~a (~v) in literal binary" b c))
                       b)
                     list->bytes
                     #\"
                     #\x
                     (lambda ()
                       (match i
                         [(px #px#"^[a-fA-F0-9]{2}" (list hexdigits))
                          (string->number (bytes->string/utf-8 hexdigits) 16)]
                         [_ (parse-error "Bad binary \\x escape")]))))

  (define (read-intpart acc-rev)
    (match (peek-char i)
      [#\0 (read-fracexp (cons (read-char i) acc-rev))]
      [_ (read-digit+ acc-rev read-fracexp)]))

  (define (read-digit* acc-rev k)
    (match (peek-char i)
      [(? char? (? char-numeric?)) (read-digit* (cons (read-char i) acc-rev) k)]
      [_ (k acc-rev)]))

  (define (read-digit+ acc-rev k)
    (match (peek-char i)
      [(? char? (? char-numeric?)) (read-digit* (cons (read-char i) acc-rev) k)]
      [_ (parse-error "Incomplete number")]))

  (define (read-fracexp acc-rev)
    (match (peek-char i)
      [#\. (read-digit+ (cons (read-char i) acc-rev) read-exp)]
      [_ (read-exp acc-rev)]))

  (define (read-exp acc-rev)
    (match (peek-char i)
      [(or #\e #\E) (read-sign-and-exp (cons (read-char i) acc-rev))]
      [_ (finish-number acc-rev)]))

  (define (read-sign-and-exp acc-rev)
    (match (peek-char i)
      [(or #\+ #\-) (read-digit+ (cons (read-char i) acc-rev) finish-number)]
      [_ (read-digit+ acc-rev finish-number)]))

  (define (finish-number acc-rev)
    (define s (list->string (reverse acc-rev)))
    (define n (string->number s))
    (when (not n) (parse-error "Invalid number: ~v" s))
    (if (flonum? n)
        (match (peek-char i)
          [(or #\f #\F) (read-char i) (real->single-flonum n)]
          [_ n])
        n))

  (define (read-number)
    (match (peek/no-eof)
      [#\- (read-intpart (list (read-char i)))]
      [_ (read-intpart (list))]))

  (define (sequence-fold acc accumulate-one finish terminator-char)
    (let loop ((acc acc))
      (skip-whitespace)
      (match (peek/no-eof)
        [(== terminator-char) (read-char i) (finish acc)]
        [_ (loop (accumulate-one acc))])))

  (define (collect-fields head)
    (skip-whitespace)
    (match (peek-char i)
      [#\(
       (read-char i)
       (collect-fields (build-record head (read-sequence #\))))]
      [_
       head]))

  (define (read-value)
    (skip-whitespace)
    (collect-fields
     (match (peek-char i)
       [(? eof-object? o) o]
       [#\{ (read-char i) (read-dictionary-or-set)]
       [#\[ (read-char i) (read-sequence #\])]
       [(or #\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (read-number)]
       [#\" (read-char i) (read-string #\")]
       [(== PIPE) (read-char i) (string->symbol (read-string PIPE))]
       [#\# (match i
              [(px #px#"^#set\\{" (list _))
               (sequence-fold (set) accumulate-value values #\})]
              [(px #px#"^#hexvalue\\{" (list _))
               (decode (read-hex-binary '()) (lambda () (parse-error "Invalid #hexvalue encoding")))]
              [(px #px#"^#true" (list _))
               #t]
              [(px #px#"^#false" (list _))
               #f]
              [(px #px#"^#\"" (list _))
               (read-literal-binary)]
              [(px #px#"^#hex\\{" (list _))
               (read-hex-binary '())]
              [(px #px#"^#base64\\{" (list _))
               (read-base64-binary '())]
              [_
               (parse-error "Invalid preserve value")])]
       [#\: (parse-error "Unexpected key/value separator between items")]
       [_ (read-raw-symbol '())])))

  (read-value))

(define (string->preserve s)
  (define p (open-input-string s))
  (define v (read-preserve p))
  (skip-whitespace* p)
  (when (not (eof-object? (peek-char p)))
    (parse-error* p "Unexpected text following preserve"))
  v)

;;---------------------------------------------------------------------------

(module+ test
  (require rackunit)
  (require (for-syntax racket syntax/srcloc))

  (check-equal? (bit-string->bytes (encode-varint 0)) (bytes 0))
  (check-equal? (bit-string->bytes (encode-varint 1)) (bytes 1))
  (check-equal? (bit-string->bytes (encode-varint 127)) (bytes 127))
  (check-equal? (bit-string->bytes (encode-varint 128)) (bytes 128 1))
  (check-equal? (bit-string->bytes (encode-varint 255)) (bytes 255 1))
  (check-equal? (bit-string->bytes (encode-varint 256)) (bytes 128 2))
  (check-equal? (bit-string->bytes (encode-varint 300)) (bytes #b10101100 #b00000010))
  (check-equal? (bit-string->bytes (encode-varint 1000000000)) (bytes 128 148 235 220 3))

  (define (ks* v rest) (list v (bit-string->bytes rest)))
  (define (kf*) (void))

  (check-equal? (decode-varint (bytes 0) ks* kf*) (list 0 (bytes)))
  (check-equal? (decode-varint (bytes 0 99) ks* kf*) (list 0 (bytes 99)))
  (check-equal? (decode-varint (bytes 1) ks* kf*) (list 1 (bytes)))
  (check-equal? (decode-varint (bytes 127) ks* kf*) (list 127 (bytes)))
  (check-equal? (decode-varint (bytes 128 1) ks* kf*) (list 128 (bytes)))
  (check-equal? (decode-varint (bytes 128 1 99) ks* kf*) (list 128 (bytes 99)))
  (check-equal? (decode-varint (bytes 255 1) ks* kf*) (list 255 (bytes)))
  (check-equal? (decode-varint (bytes 128 2) ks* kf*) (list 256 (bytes)))
  (check-equal? (decode-varint (bytes #b10101100 #b00000010) ks* kf*) (list 300 (bytes)))
  (check-equal? (decode-varint (bytes 128 148 235 220 3) ks* kf*) (list 1000000000 (bytes)))
  (check-equal? (decode-varint (bytes 128 148 235 220 3 99) ks* kf*) (list 1000000000 (bytes 99)))

  (check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (0 :: (wire-length)))) (bytes 0))
  (check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (3 :: (wire-length)))) (bytes 3))
  (check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (14 :: (wire-length)))) (bytes 14))
  (check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (15 :: (wire-length)))) (bytes 15 15))
  (check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (100 :: (wire-length))))
                (bytes 15 100))
  (check-equal? (bit-string->bytes (bit-string (0 :: bits 4) (300 :: (wire-length))))
                (bytes 15 #b10101100 #b00000010))

  (define (dwl bs)
    (bit-string-case bs
      ([ (= 0 :: bits 4) (w :: (wire-length)) ] w)
      (else (void))))

  (check-equal? (dwl (bytes 0)) 0)
  (check-equal? (dwl (bytes 3)) 3)
  (check-equal? (dwl (bytes 14)) 14)
  (check-equal? (dwl (bytes 15)) (void))
  (check-equal? (dwl (bytes 15 9)) (void)) ;; not canonical
  (check-equal? (dwl (bytes 15 15)) 15)
  (check-equal? (dwl (bytes 15 100)) 100)
  (check-equal? (dwl (bytes 15 #b10101100 #b00000010)) 300)

  (struct speak (who what) #:prefab)

  (define (expected . pieces)
    (bit-string->bytes
     (apply bit-string-append
            (map (match-lambda
                   [(? byte? b) (bytes b)]
                   [(? bytes? bs) bs]
                   [(? string? s) (string->bytes/utf-8 s)])
                 pieces))))

  (define (d bs) (decode bs void))

  (define-syntax (cross-check stx)
    (syntax-case stx ()
      ((_ text v (b ...))
       #'(let ((val v)) (cross-check text v v (b ...))))
      ((_ text forward back (b ...))
       #`(let ((loc #,(source-location->string #'forward)))
           (check-equal? (string->preserve text) back loc)
           (check-equal? (d (encode forward)) back loc)
           (check-equal? (d (encode back)) back loc)
           (check-equal? (d (expected b ...)) back loc)
           (check-equal? (encode forward) (expected b ...) loc)
           ))))

  (define-syntax (cross-check/nondeterministic stx)
    (syntax-case stx ()
      ((_ text v (b ...))
       #'(let ((val v)) (cross-check/nondeterministic text v v (b ...))))
      ((_ text forward back (b ...))
       #`(let ((loc #,(source-location->string #'forward)))
           (check-equal? (string->preserve text) back loc)
           (check-equal? (d (encode forward)) back loc)
           (check-equal? (d (encode back)) back loc)
           (check-equal? (d (expected b ...)) back loc)
           ))))

  (cross-check "capture(discard())" (capture (discard)) (#x91 #x80))
  (cross-check "observe(speak(discard(), capture(discard())))"
               (observe (speak (discard) (capture (discard))))
               (#xA1 #xB3 #x75 "speak" #x80 #x91 #x80))
  (cross-check "[1, 2, 3, 4]" '(1 2 3 4) (#xC4 #x11 #x12 #x13 #x14))
  (cross-check "[1 2 3 4]"
               (stream-of 'sequence (sequence->generator '(1 2 3 4)))
               '(1 2 3 4)
               (#x2C #x11 #x12 #x13 #x14 #x3C))
  (cross-check " [ -2 -1 0 1 ] " '(-2 -1 0 1) (#xC4 #x1E #x1F #x10 #x11))
  (cross-check "\"hello\"" "hello" (#x55 "hello"))
  (cross-check "\"hello\""
               (stream-of 'string (sequence->generator '(#"he" #"llo")))
               "hello"
               (#x25 #x62 "he" #x63 "llo" #x35))
  (cross-check "\"hello\""
               (stream-of 'string (sequence->generator '(#"he" #"ll" #"" #"" #"o")))
               "hello"
               (#x25 #x62 "he" #x62 "ll" #x60 #x60 #x61 "o" #x35))
  (cross-check "#\"hello\""
               (stream-of 'byte-string (sequence->generator '(#"he" #"ll" #"" #"" #"o")))
               #"hello"
               (#x26 #x62 "he" #x62 "ll" #x60 #x60 #x61 "o" #x36))
  (cross-check "hello"
               (stream-of 'symbol (sequence->generator '(#"he" #"ll" #"" #"" #"o")))
               'hello
               (#x27 #x62 "he" #x62 "ll" #x60 #x60 #x61 "o" #x37))
  (cross-check "[\"hello\" there #\"world\" [] #set{} #true #false]"
               `("hello" there #"world" () ,(set) #t #f)
               (#xC7 #x55 "hello" #x75 "there" #x65 "world" #xC0 #xD0 #x01 #x00))

  (cross-check "#\"ABC\"" #"ABC" (#x63 #x41 #x42 #x43))
  (cross-check "#hex{414243}" #"ABC" (#x63 #x41 #x42 #x43))
  (cross-check "#hex{ 41 4A 4e }" #"AJN" (#x63 #x41 #x4A #x4E))
  (cross-check "#hex{ 41;re\n 42 43 }" #"ABC" (#x63 #x41 #x42 #x43))
  (check-exn exn? (lambda () (string->preserve "#hex{414 243}"))) ;; bytes must be 2-digits entire
  (cross-check "#base64{Y29yeW1i}" #"corymb" (#x66 "corymb"))
  (cross-check "#base64{Y29 yeW 1i}" #"corymb" (#x66 "corymb"))
  (cross-check ";; a comment\n#base64{\n;x\nY29 yeW 1i}" #"corymb" (#x66 "corymb"))
  (cross-check "#base64{SGk=}" #"Hi" (#x62 "Hi"))
  (cross-check "#base64{SGk}" #"Hi" (#x62 "Hi"))
  (cross-check "#base64{ S G k }" #"Hi" (#x62 "Hi"))

  (cross-check "\"abc\\u6c34\\u6C34\\\\\\/\\\"\\b\\f\\n\\r\\txyz\""
               "abc\u6c34\u6c34\\/\"\b\f\n\r\txyz"
               (#x5f #x14
                     #x61 #x62 #x63 #xe6 #xb0 #xb4 #xe6 #xb0
                     #xb4 #x5c #x2f #x22 #x08 #x0c #x0a #x0d
                     #x09 #x78 #x79 #x7a))

  (cross-check "|abc\\u6c34\\u6C34\\\\\\/\\|\\b\\f\\n\\r\\txyz|"
               (string->symbol "abc\u6c34\u6c34\\/|\b\f\n\r\txyz")
               (#x7f #x14
                     #x61 #x62 #x63 #xe6 #xb0 #xb4 #xe6 #xb0
                     #xb4 #x5c #x2f #x7c #x08 #x0c #x0a #x0d
                     #x09 #x78 #x79 #x7a))

  (check-exn #px"Invalid escape code \\\\u" (lambda () (string->preserve "#\"\\u6c34\"")))

  (cross-check "#\"abc\\x6c\\x34\\xf0\\\\\\/\\\"\\b\\f\\n\\r\\txyz\""
               #"abc\x6c\x34\xf0\\/\"\b\f\n\r\txyz"
               (#x6f #x11
                     #x61 #x62 #x63 #x6c #x34 #xf0 #x5c #x2f
                     #x22 #x08 #x0c #x0a #x0d #x09 #x78 #x79 #x7a))

  (cross-check "\"\\uD834\\uDD1E\"" "\U0001D11E" (#x54 #xF0 #x9D #x84 #x9E))

  (cross-check "-257" -257 (#x42 #xFE #xFF))
  (cross-check "-256" -256 (#x42 #xFF #x00))
  (cross-check "-255" -255 (#x42 #xFF #x01))
  (cross-check "-254" -254 (#x42 #xFF #x02))
  (cross-check "-129" -129 (#x42 #xFF #x7F))
  (cross-check "-128" -128 (#x41 #x80))
  (cross-check "-127" -127 (#x41 #x81))
  (cross-check "-4" -4 (#x41 #xFC))
  (cross-check "-3" -3 (#x1D))
  (cross-check "-2" -2 (#x1E))
  (cross-check "-1" -1 (#x1F))
  (cross-check "0" 0 (#x10))
  (cross-check "1" 1 (#x11))
  (cross-check "12" 12 (#x1C))
  (cross-check "13" 13 (#x41 #x0D))
  (cross-check "127" 127 (#x41 #x7F))
  (cross-check "128" 128 (#x42 #x00 #x80))
  (cross-check "255" 255 (#x42 #x00 #xFF))
  (cross-check "256" 256 (#x42 #x01 #x00))
  (cross-check "32767" 32767 (#x42 #x7F #xFF))
  (cross-check "32768" 32768 (#x43 #x00 #x80 #x00))
  (cross-check "65535" 65535 (#x43 #x00 #xFF #xFF))
  (cross-check "65536" 65536 (#x43 #x01 #x00 #x00))
  (cross-check "131072" 131072 (#x43 #x02 #x00 #x00))

  (cross-check "1.0f" 1.0f0 (#b00000010 #b00111111 #b10000000 0 0))
  (cross-check "1.0" 1.0 (#b00000011 #b00111111 #b11110000 0 0 0 0 0 0))
  (cross-check "-1.202e300" -1.202e300 (#x03 #xFE #x3C #xB7 #xB7 #x59 #xBF #x04 #x26))

  (check-equal? (d (expected #x25 #x51 "a" #x35)) (void)) ;; Bad chunk type: must be bytes
  (check-equal? (d (expected #x25 #x71 "a" #x35)) (void)) ;; Bad chunk type: must be bytes
  (check-equal? (d (expected #x26 #x51 "a" #x36)) (void)) ;; Bad chunk type: must be bytes
  (check-equal? (d (expected #x26 #x71 "a" #x36)) (void)) ;; Bad chunk type: must be bytes
  (check-equal? (d (expected #x27 #x51 "a" #x37)) (void)) ;; Bad chunk type: must be bytes
  (check-equal? (d (expected #x27 #x71 "a" #x37)) (void)) ;; Bad chunk type: must be bytes
  (check-equal? (d (expected #x25 #x61 "a" #x35)) "a")
  (check-equal? (d (expected #x26 #x61 "a" #x36)) #"a")
  (check-equal? (d (expected #x27 #x61 "a" #x37)) 'a)

  (struct date (year month day) #:prefab)
  (struct thing (id) #:prefab)
  (struct person thing (name date-of-birth) #:prefab)
  (struct titled person (title) #:prefab)

  (cross-check
   "[titled person 2 thing 1](101, \"Blackwell\", date(1821 2 3), \"Dr\")"
   (titled 101 "Blackwell" (date 1821 2 3) "Dr")
   (#xB5                                                ;; Record, generic, 4+1
      #xC5                                                ;; Sequence, 5
        #x76 #x74 #x69 #x74 #x6C #x65 #x64                  ;; Symbol, "titled"
        #x76 #x70 #x65 #x72 #x73 #x6F #x6E                  ;; Symbol, "person"
        #x12                                                ;; SignedInteger, "2"
        #x75 #x74 #x68 #x69 #x6E #x67                       ;; Symbol, "thing"
        #x11                                                ;; SignedInteger, "1"
      #x41 #x65                                           ;; SignedInteger, "101"
      #x59 #x42 #x6C #x61 #x63 #x6B #x77 #x65 #x6C #x6C   ;; String, "Blackwell"
      #xB4                                                ;; Record, generic, 3+1
        #x74 #x64 #x61 #x74 #x65                            ;; Symbol, "date"
        #x42 #x07 #x1D                                      ;; SignedInteger, "1821"
        #x12                                                ;; SignedInteger, "2"
        #x13                                                ;; SignedInteger, "3"
      #x52 #x44 #x72                                      ;; String, "Dr"
      ))

  (cross-check "discard()" (record 'discard '()) (discard) (#x80))
  (cross-check "discard(surprise)"
               (record 'discard '(surprise))
               '#s(discard surprise)
               (#x81 #x78 "surprise"))
  (cross-check "capture(x)" (record 'capture '(x)) (capture 'x) (#x91 #x71 "x"))
  (cross-check "observe(x)" (record 'observe '(x)) (observe 'x) (#xA1 #x71 "x"))
  (cross-check "observe(x y)" (record 'observe '(x y)) '#s(observe x y) (#xA2 #x71 "x" #x71 "y"))
  (cross-check "other(x y)"
               (record 'other '(x y))
               '#s(other x y)
               (#xB3 #x75 "other" #x71 "x" #x71 "y"))
  (cross-check "\"aString\"(3 4)"
               (record "aString" '(3 4))
               (#xB3 #x57 "aString" #x13 #x14))
  (cross-check "discard()(3, 4)"
               (record (discard) '(3 4))
               (#xB3 #x80 #x13 #x14))

  (check-equal? (d (expected #x2C #x00 #x00)) (void)) ;; missing end byte
  (check-equal? (d (expected #xC3 #x00 #x00)) (void)) ;; missing element

  (cross-check/nondeterministic
   "{a: 1, \"b\": #true, [1 2 3]: #\"c\", {first-name:\"Elizabeth\"}:{surname:\"Blackwell\"}}"
   (hash 'a 1
         "b" #t
         '(1 2 3) #"c"
         (hash 'first-name "Elizabeth") (hash 'surname "Blackwell"))
   (#xE8 #x71 "a" #x11
         #x51 "b" #x01
         #xC3 #x11 #x12 #x13 #x61 "c"
         #xE2 #x7A "first-name" #x59 "Elizabeth"
           #xE2 #x77 "surname" #x59 "Blackwell"
           ))

  (let ()
    (local-require json)
    (define rfc8259-example1 (string->preserve #<<EOF
{
  "Image": {
      "Width":  800,
      "Height": 600,
      "Title":  "View from 15th Floor",
      "Thumbnail": {
          "Url":    "http://www.example.com/image/481989943",
          "Height": 125,
          "Width":  100
      },
      "Animated" : false,
      "IDs": [116, 943, 234, 38793]
    }
}
EOF
                                             ))
    (define rfc8259-example2 (string->preserve #<<EOF
[
  {
     "precision": "zip",
     "Latitude":  37.7668,
     "Longitude": -122.3959,
     "Address":   "",
     "City":      "SAN FRANCISCO",
     "State":     "CA",
     "Zip":       "94107",
     "Country":   "US"
  },
  {
     "precision": "zip",
     "Latitude":  37.371991,
     "Longitude": -122.026020,
     "Address":   "",
     "City":      "SUNNYVALE",
     "State":     "CA",
     "Zip":       "94085",
     "Country":   "US"
  }
]
EOF
                                             ))

    (cross-check/nondeterministic
     "{\"Image\": {\"Width\":  800,\"Height\": 600,\"Title\":  \"View from 15th Floor\",\"Thumbnail\": {\"Url\":    \"http://www.example.com/image/481989943\",\"Height\": 125,\"Width\":  100},\"Animated\" : false,\"IDs\": [116, 943, 234, 38793]}}"
     rfc8259-example1
     (#xe2
        #x55 "Image"
        #xec
          #x55 "Width"    #x42 #x03 #x20
          #x55 "Title"    #x5f #x14 "View from 15th Floor"
          #x58 "Animated" #x75 "false"
          #x56 "Height"   #x42 #x02 #x58
          #x59 "Thumbnail"
            #xe6
              #x55 "Width"  #x41 #x64
              #x53 "Url"    #x5f #x26 "http://www.example.com/image/481989943"
              #x56 "Height" #x41 #x7d
              #x53 "IDs"    #xc4
                              #x41 #x74
                              #x42 #x03 #xaf
                              #x42 #x00 #xea
                              #x43 #x00 #x97 #x89
     ))

    (cross-check/nondeterministic
     "[{\"precision\": \"zip\",\"Latitude\":  37.7668,\"Longitude\": -122.3959,\"Address\":   \"\",\"City\":      \"SAN FRANCISCO\",\"State\":     \"CA\",\"Zip\":       \"94107\",\"Country\":   \"US\"},{\"precision\": \"zip\",\"Latitude\":  37.371991,\"Longitude\": -122.026020,\"Address\":   \"\",\"City\":      \"SUNNYVALE\",\"State\":     \"CA\",\"Zip\":       \"94085\",\"Country\":   \"US\"}]"
     rfc8259-example2
     (#xc2
        #xef #x10
          #x59 "precision"  #x53 "zip"
          #x58 "Latitude"   #x03 #x40 #x42 #xe2 #x26 #x80 #x9d #x49 #x52
          #x59 "Longitude"  #x03 #xc0 #x5e #x99 #x56 #x6c #xf4 #x1f #x21
          #x57 "Address"    #x50
          #x54 "City"       #x5D "SAN FRANCISCO"
          #x55 "State"      #x52 "CA"
          #x53 "Zip"        #x55 "94107"
          #x57 "Country"    #x52 "US"
        #xef #x10
          #x59 "precision"  #x53 "zip"
          #x58 "Latitude"   #x03 #x40 #x42 #xaf #x9d #x66 #xad #xb4 #x03
          #x59 "Longitude"  #x03 #xc0 #x5e #x81 #xaa #x4f #xca #x42 #xaf
          #x57 "Address"    #x50
          #x54 "City"       #x59 "SUNNYVALE"
          #x55 "State"      #x52 "CA"
          #x53 "Zip"        #x55 "94085"
          #x57 "Country"    #x52 "US"
          ))
    )
  )