#lang scheme
(require
 "packing.ss")

(define packing-big-endian?
  (make-parameter (system-big-endian?)))

(define (big-endian/p packing)
  (make-packing
   (λ (in)
     (parameterize ([packing-big-endian? #t])
       ((packing-reader packing) in)))
   (λ (v out)
     (parameterize ([packing-big-endian? #t])
       ((packing-writer packing) v out)))
   (packing-contract packing)))

(define (little-endian/p packing)
  (make-packing
   (λ (in)
     (parameterize ([packing-big-endian? #f])
       ((packing-reader packing) in)))
   (λ (v out)
     (parameterize ([packing-big-endian? #f])
       ((packing-writer packing) v out)))
   (packing-contract packing)))

(define (native-endian/p packing)
  (make-packing
   (λ (in)
     (parameterize ([packing-big-endian? (system-big-endian?)])
       ((packing-reader packing) in)))
   (λ (v out)
     (parameterize ([packing-big-endian? (system-big-endian?)])
       ((packing-writer packing) v out)))
   (packing-contract packing)))

(provide/contract
 [packing-big-endian? (parameter/c any/c)]
 [big-endian/p (-> packing? packing?)]
 [little-endian/p (-> packing? packing?)]
 [native-endian/p (-> packing? packing?)])

(define (integer/p size signed?)
  (make-packing
   (case size
     [(1)
      (λ (in)
        (let*-values ([(line col pos) (port-next-location in)]
                      [(v) (read-byte in)])
          (if (or (not signed?) (eof-object? v) (zero? (bitwise-and #x80 v)))
              v
              (- v #x100))))]
     [else
      (λ (in)
        (let*-values ([(line col pos) (port-next-location in)]
                      [(b) (read-bytes size in)])
          (if (and (bytes? b) (= (bytes-length b) size))
              (integer-bytes->integer b signed? (packing-big-endian?))
              eof)))])
   (case size
     [(1)
      (λ (v out)
        (write-byte
         (if (or (not signed?) (positive? v))
             v
             (+ #x100 v))
         out))]
     [else
      (λ (v out)
        (write-bytes
         (integer->integer-bytes v size signed? (packing-big-endian?))
         out))])
   (let ([bits (* size 8)])
     (if signed?
         (let ([bound (expt 2 (- (* size 8) 1))])
           (integer-in (- bound) (- bound 1)))
         (integer-in 0 (- (expt 2 (* size 8)) 1))))))

(define sint8/p
  (integer/p 1 #t))
(define uint8/p
  (integer/p 1 #f))
(define int8/p
  sint8/p)

(define sint16/p
  (integer/p 2 #t))
(define uint16/p
  (integer/p 2 #f))
(define int16/p
  sint16/p)

(define sint32/p
  (integer/p 4 #t))
(define uint32/p
  (integer/p 4 #f))
(define int32/p
  sint32/p)

(define sint64/p
  (integer/p 8 #t))
(define uint64/p
  (integer/p 8 #f))
(define int64/p
  sint64/p)

(define sbyte/p
  sint8/p)
(define ubyte/p
  uint8/p)
(define byte/p
  int8/p)

(define sshort/p
  sint16/p)
(define ushort/p
  uint16/p)
(define short/p
  int16/p)

(define sint/p
  sint32/p)
(define uint/p
  uint32/p)
(define int/p
  int32/p)

(define slong/p
  sint64/p)
(define ulong/p
  uint64/p)
(define long/p
  int64/p)

(provide/contract
 [integer/p (-> (or/c 1 2 4 8) any/c packing?)])

(provide
 sint8/p uint8/p int8/p
 sint16/p uint16/p int16/p
 sint32/p uint32/p int32/p
 sint64/p uint64/p int64/p
 sbyte/p ubyte/p byte/p
 sshort/p ushort/p short/p
 sint/p uint/p int/p
 slong/p ulong/p long/p)

(define (real/p size)
  (make-packing
   (λ (in)
     (let*-values ([(line col pos) (port-next-location in)]
                   [(b) (read-bytes size in)])
       (if (and (bytes? b) (= (bytes-length b) size))
           (floating-point-bytes->real b (packing-big-endian?))
           eof)))
   (λ (v out)
     (write-bytes
      (real->floating-point-bytes v size (packing-big-endian?))
      out))
   real?))

(define float/p
  (real/p 4))

(define double/p
  (real/p 8))

(provide/contract
 [real/p (-> (or/c 4 8) packing?)])

(provide
 float/p double/p)

(define (character/p size)
  (wrap/p
   integer->char
   char->integer
   (integer/p size #f)
   char?))

(define char/p
  (character/p 1))
(define wchar/p
  (character/p 2))

(provide/contract
 [character/p (-> (or/c 1 2 4 8) packing?)])

(provide
 char/p wchar/p)

(define bool/p
  (wrap/p
   (λ (v)
     (not (zero? v)))
   (λ (v)
     (if v 1 0))
   ubyte/p))

(provide
 bool/p)