Binary.carp

(system-include "carp_binary.h")
(load "StdInt.carp")

;; Helper functions for making working with Maybe easier
;; TODO: Replace all of these with a single type-generic
;; zip-n macro.
(defmodule Maybe
  (defndynamic zip- [f args names]
    (if (empty? args)
      `(Maybe.Just (~%f %@names))
      (let [n (gensym-with 'zip)]
        `(match %(car args)
          (Maybe.Nothing) (Maybe.Nothing)
          (Maybe.Just %n) %(Maybe.zip- f (cdr args) (cons-last n names))))))

  (defmacro zip [f :rest args]
    (Maybe.zip- f args '()))
)

;; Temporary fix for issue #698
;; The underlying issue is deeper, and should probably be fixed.
(doc ByteOrder
    "The type of byte orders.

    LittleEndian designates the little endian ordering, and indicates the least
    significant byte appears first in a given byte sequence.

    BigEndian designates the big endian ordering, and indicates the most
    significant byte occurs first in a given byte sequence.")
  (deftype ByteOrder LittleEndian BigEndian)

(defmodule ByteOrder
  (defn blit [x] (the ByteOrder x))
  (implements blit blit)
)

(doc Binary "provides various helper functions to work with bits and bytes.")
(defmodule Binary
  (register to-int16 (λ [Byte Byte] Uint16))
  (register to-int32 (λ [Byte Byte Byte Byte] Uint32))
  (register to-int64 (λ [Byte Byte Byte Byte Byte Byte Byte Byte] Uint64))
  (register int16-to-byte  (λ [(Ref Uint16)] Byte))
  (register int32-to-byte  (λ [(Ref Uint32)] Byte))
  (register int64-to-byte  (λ [(Ref Uint64)] Byte))
  (register system-endianness-internal (λ [] Int))

  (defn unwrap-success [x]
    (Result.unwrap-or-zero @x))

  (defn unwrap-error [x]
    (Result.from-error @x (zero)))

  (doc byte-converter
    "Returns a function that, when called, attempts to convert an array of bytes using `f` and `order`

     If the conversion is successful, returns a `Result.Success` containing the converted value.

     If the conversion fails, returns a `Result.Error` containing the byte array passed as an argument.")
  (defn byte-converter [f order]
     (fn [bs]
       (match (~f order bs)
              (Maybe.Nothing) (Result.Error @bs)
              (Maybe.Just i)  (Result.Success i))))
  (doc interpreted
    "Returns the interpreted value from a sequence of byte-converion results")
  (private interpreted)
  (defn interpreted [results]
    (==> results
         (Array.copy-filter &Result.success?)
         (ref)
         (Array.copy-map &unwrap-success)))

  (doc remaining-bytes
    "Returns the number of uninterpreted bytes from a seuqence of byte-conversion results")
  (private remaining-bytes)
  (defn remaining-bytes [results]
    (==> results
         (Array.copy-filter &Result.error?)
         (ref)
         (Array.copy-map &unwrap-error)
         (ref)
         (Array.copy-map &Array.length)
         (ref)
         (Array.reduce &(fn [x y] (+ x @y)) 0)))

  (doc system-endianness
    "Returns the endianness of the host system.")
  (sig system-endianness (λ [] ByteOrder))
  (defn system-endianness []
    (if (= (system-endianness-internal) 1)
        (ByteOrder.LittleEndian)
        (ByteOrder.BigEndian)))

  (doc unsafe-bytes->int16
    "Interprets the first two bytes in a byte sequence as an Uint16 value.
     **This operation is unsafe.**")
  (sig unsafe-bytes->int16 (Fn [ByteOrder (Ref (Array Byte) a)] Uint16))
  (defn unsafe-bytes->int16 [order bs]
    (match order
      (ByteOrder.LittleEndian)
        (to-int16 @(Array.unsafe-nth bs 0) @(Array.unsafe-nth bs 1))
      (ByteOrder.BigEndian)
        (to-int16 @(Array.unsafe-nth bs 1) @(Array.unsafe-nth bs 0))))

  (doc bytes->int16
    "Interprets the first two bytes in a byte sequence as an Uint16 value.

     If the first two bytes are inaccessible, or the given array contains less
     than two bytes, returns Maybe.Nothing.")
  (sig bytes->int16 (Fn [ByteOrder (Ref (Array Byte) a)] (Maybe Uint16)))
  (defn bytes->int16 [order bytes]
    (match order
      (ByteOrder.LittleEndian)
        (Maybe.zip &to-int16 (Array.nth bytes 0) (Array.nth bytes 1))
      (ByteOrder.BigEndian)
        (Maybe.zip &to-int16 (Array.nth bytes 1) (Array.nth bytes 0))))

  (doc int16->bytes
    "Converts a Uint16 to a sequence of bytes representing the value using the provided `order`")
  (sig int16->bytes (Fn [ByteOrder Uint16] (Array Byte)))
  (defn int16->bytes [order i]
    (match order
      (ByteOrder.LittleEndian)
        (Array.copy-map &int16-to-byte &[i (Uint16.bit-shift-right i (Uint16.from-long 8l))])
      (ByteOrder.BigEndian)
        (Array.copy-map &int16-to-byte &[(Uint16.bit-shift-right i (Uint16.from-long 8l)) i])))

  (doc unsafe-bytes->int16-seq
    "Interprets a sequence of bytes as a sequence of Uint16 values.
     **This operation is unsafe.**")
  (sig unsafe-bytes->int16-seq (Fn [ByteOrder (Ref (Array Byte) a)] (Array Uint16)))
  (defn unsafe-bytes->int16-seq [order bs]
    (let [partitions (Array.partition bs 2)
          f (fn [b] (unsafe-bytes->int16 order b))]
      (Array.copy-map &f &partitions)))

  (doc bytes->int16-seq
    "Interprets a sequence of bytes as a sequence of Uint16 values.

     Returns a pair containing interpreted values and the number of bytes that were not interpreted.")
  (sig bytes->int16-seq (Fn [ByteOrder (Ref (Array Byte) a)] (Pair (Array Uint16) Int)))
  (defn bytes->int16-seq [order bs]
    (let [partitions (Array.partition bs 2)
          f (byte-converter &bytes->int16 order)]
      (let [results (Array.copy-map &f &partitions)]
        (Pair.init (interpreted &results) (remaining-bytes &results)))))

  (doc bytes->int16-seq-exact
    "Attempts to interpret a given byte sequence as an exact sequence of Uint16 values.

     If successful, returns the interpreted values. If unsuccessful, returns the number of excess bytes.")
  (sig bytes->int16-seq-exact (Fn [ByteOrder (Ref (Array Byte) a)] (Result (Array Uint16) Int)))
  (defn bytes->int16-seq-exact [order bs]
    (let [r (bytes->int16-seq order bs)]
      (if (= 0 @(Pair.b &r))
          (Result.Success @(Pair.a &r))
          (Result.Error @(Pair.b &r)))))

  (doc int16-seq->bytes
    "Converts an array of Uint16 values into byte sequences.")
  (sig int16-seq->bytes (Fn [ByteOrder (Ref (Array Uint16) a)] (Array (Array Byte))))
  (defn int16-seq->bytes [order is]
    (let [f (fn [i] (int16->bytes order @i))]
      (Array.copy-map &f is)))

  (doc unsafe-bytes->int32
    "Interprets the first four bytes in a byte sequence as an Uint32 value.
     **This operation is unsafe.**")
  (sig unsafe-bytes->int32 (Fn [ByteOrder (Ref (Array Byte))] Uint32))
  (defn unsafe-bytes->int32 [order bs]
    (match order
      (ByteOrder.LittleEndian)
        (to-int32 @(Array.unsafe-nth bs 0) @(Array.unsafe-nth bs 1)
                  @(Array.unsafe-nth bs 2) @(Array.unsafe-nth bs 3))
      (ByteOrder.BigEndian)
        (to-int32 @(Array.unsafe-nth bs 3) @(Array.unsafe-nth bs 2)
                  @(Array.unsafe-nth bs 1) @(Array.unsafe-nth bs 0))))

  (doc bytes->int32
    "Interprets the first four bytes in a byte sequence as an Uint32 value.

     If the first four bytes are inaccessible, or the given array contains less
     than four bytes, returns Maybe.Nothing.")
  (sig bytes->int32 (Fn [ByteOrder (Ref (Array Byte))] (Maybe Uint32)))
  (defn bytes->int32 [order bs]
    (match order
      (ByteOrder.LittleEndian)
        (Maybe.zip &to-int32 (Array.nth bs 0) (Array.nth bs 1)
                             (Array.nth bs 2) (Array.nth bs 3))
      (ByteOrder.BigEndian)
        (Maybe.zip &to-int32 (Array.nth bs 3) (Array.nth bs 2)
                             (Array.nth bs 1) (Array.nth bs 0))))

  (doc int32->bytes
    "Converts a Uint32 to a sequence of bytes representing the value using the provided `order`")
  (sig int32->bytes (Fn [ByteOrder Uint32] (Array Byte)))
  (defn int32->bytes [order i]
    (let [shift (fn [lng] (Uint32.bit-shift-right i (Uint32.from-long lng)))]
      (match order
        (ByteOrder.LittleEndian)
          (Array.copy-map &int32-to-byte
            &[i (shift 8l) (shift 16l) (shift 24l)])
        (ByteOrder.BigEndian)
          (Array.copy-map &int32-to-byte
            &[(shift 24l) (shift 16l) (shift 8l) i]))))

  (doc unsafe-bytes->int32-seq
    "Interprets a sequence of bytes as a sequence of Uint32 values.
     **This operation is unsafe.**")
  (sig unsafe-bytes->int32-seq (Fn [ByteOrder (Ref (Array Byte) a)] (Array Uint32)))
  (defn unsafe-bytes->int32-seq [order bs]
    (let [partitions (Array.partition bs 4)
          f (fn [b] (unsafe-bytes->int32 order b))]
      (Array.copy-map &f &partitions)))

  (doc bytes->int32-seq
    "Interprets a sequence of bytes as a sequence of Uint32 values.

     Returns a pair containing interpreted values and the number of bytes that were not interpreted.")
  (sig bytes->int32-seq (Fn [ByteOrder (Ref (Array Byte) a)] (Pair (Array Uint32) Int)))
  (defn bytes->int32-seq [order bs]
    (let [partitions (Array.partition bs 4)
          f (byte-converter &bytes->int32 order)]
      (let [results (Array.copy-map &f &partitions)]
        (Pair.init (interpreted &results) (remaining-bytes &results)))))

  (doc bytes->int32-seq-exact
    "Attempts to interpret a given byte sequence as an exact sequence of Uint32 values.

     If successful, returns the interpreted values. If unsuccessful, returns the number of excess bytes.")
  (sig bytes->int32-seq-exact (Fn [ByteOrder (Ref (Array Byte) a)] (Result (Array Uint32) Int)))
  (defn bytes->int32-seq-exact [order bs]
    (let [r (bytes->int32-seq order bs)]
      (if (= 0 @(Pair.b &r))
          (Result.Success @(Pair.a &r))
          (Result.Error @(Pair.b &r)))))

  (doc int32-seq->bytes
    "Converts an array of Uint32 values into byte sequences.")
  (sig int32-seq->bytes (Fn [ByteOrder (Ref (Array Uint32) a)] (Array (Array Byte))))
  (defn int32-seq->bytes [order is]
    (let [f (fn [i] (int32->bytes order @i))]
      (Array.copy-map &f is)))

  (doc unsafe-bytes->int64
    "Interprets the first eight bytes in a byte sequence as an Uint64 value.
     **This operation is unsafe.**")
  (sig unsafe-bytes->int64 (Fn [ByteOrder (Ref (Array Byte) a)] Uint64))
  (defn unsafe-bytes->int64 [order bs]
    (match order
      (ByteOrder.LittleEndian)
        (to-int64 @(Array.unsafe-nth bs 0) @(Array.unsafe-nth bs 1)
                  @(Array.unsafe-nth bs 2) @(Array.unsafe-nth bs 3)
                  @(Array.unsafe-nth bs 4) @(Array.unsafe-nth bs 5)
                  @(Array.unsafe-nth bs 6) @(Array.unsafe-nth bs 7))
      (ByteOrder.BigEndian)
        (to-int64 @(Array.unsafe-nth bs 7) @(Array.unsafe-nth bs 6)
                  @(Array.unsafe-nth bs 5) @(Array.unsafe-nth bs 4)
                  @(Array.unsafe-nth bs 3) @(Array.unsafe-nth bs 2)
                  @(Array.unsafe-nth bs 1) @(Array.unsafe-nth bs 0))))

  (doc bytes->int64
    "Interprets the first eight bytes in a byte sequence as an Uint64 value.

     If the first eight bytes are inaccessible, or the given array contains less
     than eight bytes, returns Maybe.Nothing.")
  (sig bytes->int64 (Fn [ByteOrder (Ref (Array Byte) a)] (Maybe Uint64)))
  (defn bytes->int64 [order bs]
    (match order
      (ByteOrder.LittleEndian)
        (Maybe.zip &to-int64 (Array.nth bs 0) (Array.nth bs 1)
                             (Array.nth bs 2) (Array.nth bs 3)
                             (Array.nth bs 4) (Array.nth bs 5)
                             (Array.nth bs 6) (Array.nth bs 7))
      (ByteOrder.BigEndian)
        (Maybe.zip &to-int64 (Array.nth bs 7) (Array.nth bs 6)
                             (Array.nth bs 5) (Array.nth bs 4)
                             (Array.nth bs 3) (Array.nth bs 2)
                             (Array.nth bs 1) (Array.nth bs 0))))
  (doc int64->bytes
    "Converts a Uint64 to a sequence of bytes representing the value using the provided `order`")
  (sig int64->bytes (Fn [ByteOrder Uint64] (Array Byte)))
  (defn int64->bytes [order i]
    (let [shift (fn [lng] (Uint64.bit-shift-right i (Uint64.from-long lng)))]
      (match order
        (ByteOrder.LittleEndian)
          (Array.copy-map &int64-to-byte
            &[i (shift 8l) (shift 16l)
                (shift 24l) (shift 32l)
                (shift 40l) (shift 48l) (shift 56l)])
        (ByteOrder.BigEndian)
          (Array.copy-map &int64-to-byte
            &[(shift 56l) (shift 48l)
              (shift 40l) (shift 32l)
              (shift 24l) (shift 16l) (shift 8l) i]))))

  (doc unsafe-bytes->int64-seq
    "Interprets a sequence of bytes as a sequence of Uint64 values.
     **This operation is unsafe.**")
  (sig unsafe-bytes->int64-seq (Fn [ByteOrder (Ref (Array Byte) a)] (Array Uint64)))
  (defn unsafe-bytes->int64-seq [order bs]
    (let [partitions (Array.partition bs 8)
          f (fn [b] (unsafe-bytes->int64 order b))]
      (Array.copy-map &f &partitions)))

  (doc bytes->int64-seq
    "Interprets a sequence of bytes as a sequence of Uint64 values.

     Returns a pair containing interpreted values and the number of bytes that were not interpreted.")
  (sig bytes->int64-seq (Fn [ByteOrder (Ref (Array Byte) a)] (Pair (Array Uint64) Int)))
  (defn bytes->int64-seq [order bs]
    (let [partitions (Array.partition bs 8)
          f (byte-converter &bytes->int64 order)]
      (let [results (Array.copy-map &f &partitions)]
        (Pair.init (interpreted &results) (remaining-bytes &results)))))

  (doc bytes->int64-seq-exact
    "Attempts to interpret a given byte sequence as an exact sequence of Uint64 values.

     If successful, returns the interpreted values. If unsuccessful, returns the number of excess bytes.")
  (sig bytes->int64-seq-exact (Fn [ByteOrder (Ref (Array Byte) a)] (Result (Array Uint64) Int)))
  (defn bytes->int64-seq-exact [order bs]
    (let [r (bytes->int64-seq order bs)]
      (if (= 0 @(Pair.b &r))
          (Result.Success @(Pair.a &r))
          (Result.Error @(Pair.b &r)))))

  (doc int64-seq->bytes
    "Converts an array of Uint64 values into byte sequences.")
  (sig int64-seq->bytes (Fn [ByteOrder (Ref (Array Uint64) a)] (Array (Array Byte))))
  (defn int64-seq->bytes [order is]
    (let [f (fn [i] (int64->bytes order @i))]
      (Array.copy-map &f is)))

  (defn to-hex-str [b]
    (let [hi (Byte.bit-and b (from-int 0xF0))
          lo (Byte.bit-shift-left b (from-int 4))
          nib-one  (case hi
            (from-int 0x00) @"0"
            (from-int 0x10) @"1"
            (from-int 0x20) @"2"
            (from-int 0x30) @"3"
            (from-int 0x40) @"4"
            (from-int 0x50) @"5"
            (from-int 0x60) @"6"
            (from-int 0x70) @"7"
            (from-int 0x80) @"8"
            (from-int 0x90) @"9"
            (from-int 0xA0) @"A"
            (from-int 0xB0) @"B"
            (from-int 0xC0) @"C"
            (from-int 0xD0) @"D"
            (from-int 0xE0) @"E"
            (from-int 0xF0) @"F"
            @"FATAL ERROR IN BIT LAND! ALL IS LOST")
          nib-two  (case lo
            (from-int 0x00) @"0"
            (from-int 0x10) @"1"
            (from-int 0x20) @"2"
            (from-int 0x30) @"3"
            (from-int 0x40) @"4"
            (from-int 0x50) @"5"
            (from-int 0x60) @"6"
            (from-int 0x70) @"7"
            (from-int 0x80) @"8"
            (from-int 0x90) @"9"
            (from-int 0xA0) @"A"
            (from-int 0xB0) @"B"
            (from-int 0xC0) @"C"
            (from-int 0xD0) @"D"
            (from-int 0xE0) @"E"
            (from-int 0xF0) @"F"
            @"FATAL ERROR IN BIT LAND! ALL IS LOST")]
     (String.concat &[nib-one nib-two])))

  (doc bytes->hex-string
    "Converts an array of bytes to a string of its hexadecimal representation")
  (sig bytes->hex-string (Fn [(Ref (Array Byte) q)] String))
  (defn bytes->hex-string [bs]
    (let [f (fn [b] (to-hex-str @b))]
      (String.join " " &(Array.copy-map &f bs))))
)