126 lines
4.4 KiB
Racket
126 lines
4.4 KiB
Racket
#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))]))))
|