#lang racket/base

(provide read-preserve/binary
         bytes->preserve)

(require racket/match)
(require "record.rkt")
(require "float.rkt")
(require "annotation.rkt")
(require "varint.rkt")
(require racket/set)
(require (only-in racket/port call-with-input-bytes))

(define (default-on-short) (error 'read-preserve/binary "Short Preserves binary"))
(define (default-on-fail message . args) (error 'read-preserve/binary (apply format message args)))
(define (default-decode-embedded v)
  (error 'read-preserve/binary "No decode-embedded function supplied"))

(define (bytes->preserve bs
                         #:read-syntax? [read-syntax? #f]
                         #:decode-embedded [decode-embedded #f]
                         #:on-short [on-short default-on-short]
                         [on-fail default-on-fail])
  (call-with-input-bytes
   bs
   (lambda (p)
     (match (read-preserve/binary p
                                  #:read-syntax? read-syntax?
                                  #:decode-embedded decode-embedded
                                  #:on-short on-short
                                  on-fail)
       [(? eof-object?) (on-short)]
       [v v]))))

(define ((between lo hi) v) (<= lo v hi))

(define (read-preserve/binary [in-port (current-input-port)]
                              #:read-syntax? [read-syntax? #f]
                              #:decode-embedded [decode-embedded0 #f]
                              #:on-short [on-short default-on-short]
                              [on-fail default-on-fail])
  (define read-annotations? read-syntax?)
  (define decode-embedded (or decode-embedded0 default-decode-embedded))
  (let/ec return

    (define (next) (wrap (pos) (next* (next-byte))))

    (define (next* lead-byte)
      (match (next** lead-byte)
        ['#:end (return (on-fail "Unexpected sequence end marker"))]
        [v v]))

    (define pos
      (if read-syntax?
          (lambda ()
            (define-values (_line _column position) (port-next-location in-port))
            position)
          (lambda () #f)))

    (define wrap
      (if read-syntax?
          (lambda (pos0 v)
            (if (annotated? v)
                v
                (annotated '() (srcloc #f #f #f pos0 (- (pos) pos0)) v)))
          (lambda (pos0 v) v)))

    (define (next** lead-byte)
      (match lead-byte
        [#x80 #f]
        [#x81 #t]
        [#x82 (float (floating-point-bytes->real (next-bytes 4) #t 0 4))]
        [#x83 (floating-point-bytes->real (next-bytes 8) #t 0 8)]
        [#x84 '#:end]
        [#x85 (let ((a (next)))
                (if read-annotations?
                    (annotate (next) a)
                    (next)))]
        [#x86 (decode-embedded (next))]
        [(? (between #x90 #x9C) v) (- v #x90)]
        [(? (between #x9D #x9F) v) (- v #xA0)]
        [(? (between #xA0 #xAF) v) (next-integer (- v #xA0 -1))]
        [#xB0 (next-integer (next-varint))]
        [#xB1 (bytes->string/utf-8 (next-bytes (next-varint)))]
        [#xB2 (next-bytes (next-varint))]
        [#xB3 (string->symbol (bytes->string/utf-8 (next-bytes (next-varint))))]
        [#xB4 (apply (lambda (label . fields) (record label fields)) (next-items))]
        [#xB5 (next-items)]
        [#xB6 (list->set (next-items))]
        [#xB7 (build-dictionary (next-items))]
        [_ (return (on-fail "Invalid Preserves binary tag: ~v" lead-byte))]))

    (define (eof-guard v)
      (if (eof-object? v)
          (return (on-short))
          v))

    (define (next-byte) (eof-guard (read-byte in-port)))

    (define (next-bytes n)
      (define bs (eof-guard (read-bytes n in-port)))
      (if (< (bytes-length bs) n) (return (on-short)) bs))

    (define (next-varint) (eof-guard (read-varint in-port)))

    (define (next-integer n)
      (cond [(zero? n) 0]
            [else (define acc0 (next-byte))
                  (define acc (if (< acc0 128) acc0 (- acc0 256)))
                  (for/fold [(acc acc)] [(n (in-range (- n 1)))] (+ (* acc 256) (next-byte)))]))

    (define (next-items)
      (define pos0 (pos))
      (match (next** (next-byte))
        ['#:end '()]
        [v (cons (wrap pos0 v) (next-items))]))

    (define (build-dictionary items)
      (when (not (even? (length items))) (return (on-fail "Odd number of items in dictionary")))
      (apply hash items))

    (let ((pos0 (pos)))
      (match (read-byte in-port)
        [(? eof-object?) eof]
        [lead-byte (wrap pos0 (next* lead-byte))]))))