path: root/stdlib/source/lux/data/binary.lux

(.module:
  [lux (#- i64)
   ["." host]
   ["@" target]
   [abstract
    [monad (#+ do)]
    [equivalence (#+ Equivalence)]]
   [control
    ["." try (#+ Try)]
    ["." exception (#+ exception:)]]
   [data
    ["." maybe]
    [number
     ["." i64]
     ["n" nat]
     ["f" frac]]
    [text
     ["%" format (#+ format)]]
    [collection
     ["." array]]]])

(exception: #export (index-out-of-bounds {size Nat} {index Nat})
  (exception.report
   ["Size" (%.nat size)]
   ["Index" (%.nat index)]))

(template [<name>]
  [(exception: #export (<name> {size Nat} {from Nat} {to Nat})
     (exception.report
      ["Size" (%.nat size)]
      ["From" (%.nat from)]
      ["To" (%.nat to)]))]

  [slice-out-of-bounds]
  [inverted-slice]
  )

(with-expansions [<for-jvm> (as-is (type: #export Binary (host.type [byte]))

                                   (host.import: #long java/lang/Object)
                                   
                                   (host.import: #long java/lang/System
                                     (#static arraycopy [java/lang/Object int java/lang/Object int int] #try void))

                                   (host.import: #long java/util/Arrays
                                     (#static copyOfRange [[byte] int int] [byte])
                                     (#static equals [[byte] [byte]] boolean))

                                   (def: byte-mask
                                     I64
                                     (|> i64.bits-per-byte i64.mask .i64))

                                   (def: i64
                                     (-> (primitive "java.lang.Byte") I64)
                                     (|>> host.byte-to-long (:coerce I64) (i64.and ..byte-mask)))

                                   (def: byte
                                     (-> (I64 Any) (primitive "java.lang.Byte"))
                                     (for {@.old
                                           (|>> .int host.long-to-byte)

                                           @.jvm
                                           (|>> .int (:coerce (primitive "java.lang.Long")) host.long-to-byte)})))]
  (for {@.old
        (as-is <for-jvm>)

        @.jvm
        (as-is <for-jvm>)

        @.js
        (as-is (host.import: ArrayBuffer
                 (new [host.Number]))
               
               (host.import: Uint8Array
                 (new [ArrayBuffer])
                 (length host.Number))
               
               (type: #export Binary
                 Uint8Array))}))

(template: (!size binary)
  (for {@.old
        (host.array-length binary)

        @.jvm
        (host.array-length binary)

        @.js
        (f.nat (Uint8Array::length binary))}))

(template: (!read idx binary)
  (for {@.old
        (..i64 (host.array-read idx binary))

        @.jvm
        (..i64 (host.array-read idx binary))

        @.js
        (|> binary
            (: ..Binary)
            (:coerce (array.Array .Frac))
            ("js array read" idx)
            f.nat
            .i64)}))

(template: (!write idx value binary)
  (for {@.old
        (host.array-write idx (..byte value) binary)

        @.jvm
        (host.array-write idx (..byte value) binary)

        @.js
        (|> binary
            (: ..Binary)
            (:coerce (array.Array .Frac))
            ("js array write" idx (n.frac (.nat value)))
            (:coerce ..Binary))}))

(def: #export size
  (-> Binary Nat)
  (|>> !size))

(def: #export create
  (-> Nat Binary)
  (for {@.old
        (|>> (host.array byte))

        @.jvm
        (|>> (host.array byte))

        @.js
        (|>> n.frac [] ArrayBuffer::new Uint8Array::new)}))

(def: #export (fold f init binary)
  (All [a] (-> (-> I64 a a) a Binary a))
  (let [size (..!size binary)]
    (loop [idx 0
           output init]
      (if (n.< size idx)
        (recur (inc idx) (f (!read idx binary) output))
        output))))

(def: #export (read/8 idx binary)
  (-> Nat Binary (Try I64))
  (if (n.< (..!size binary) idx)
    (#try.Success (!read idx binary))
    (exception.throw ..index-out-of-bounds [(..!size binary) idx])))

(def: #export (read/16 idx binary)
  (-> Nat Binary (Try I64))
  (if (n.< (..!size binary) (n.+ 1 idx))
    (#try.Success ($_ i64.or
                      (i64.left-shift 8 (!read idx binary))
                      (!read (n.+ 1 idx) binary)))
    (exception.throw ..index-out-of-bounds [(..!size binary) idx])))

(def: #export (read/32 idx binary)
  (-> Nat Binary (Try I64))
  (if (n.< (..!size binary) (n.+ 3 idx))
    (#try.Success ($_ i64.or
                      (i64.left-shift 24 (!read idx binary))
                      (i64.left-shift 16 (!read (n.+ 1 idx) binary))
                      (i64.left-shift 8 (!read (n.+ 2 idx) binary))
                      (!read (n.+ 3 idx) binary)))
    (exception.throw ..index-out-of-bounds [(..!size binary) idx])))

(def: #export (read/64 idx binary)
  (-> Nat Binary (Try I64))
  (if (n.< (..!size binary) (n.+ 7 idx))
    (#try.Success ($_ i64.or
                      (i64.left-shift 56 (!read idx binary))
                      (i64.left-shift 48 (!read (n.+ 1 idx) binary))
                      (i64.left-shift 40 (!read (n.+ 2 idx) binary))
                      (i64.left-shift 32 (!read (n.+ 3 idx) binary))
                      (i64.left-shift 24 (!read (n.+ 4 idx) binary))
                      (i64.left-shift 16 (!read (n.+ 5 idx) binary))
                      (i64.left-shift 8 (!read (n.+ 6 idx) binary))
                      (!read (n.+ 7 idx) binary)))
    (exception.throw ..index-out-of-bounds [(..!size binary) idx])))

(def: #export (write/8 idx value binary)
  (-> Nat (I64 Any) Binary (Try Binary))
  (if (n.< (..!size binary) idx)
    (exec (|> binary
              (!write idx value))
      (#try.Success binary))
    (exception.throw ..index-out-of-bounds [(..!size binary) idx])))

(def: #export (write/16 idx value binary)
  (-> Nat (I64 Any) Binary (Try Binary))
  (if (n.< (..!size binary) (n.+ 1 idx))
    (exec (|> binary
              (!write idx (i64.logic-right-shift 8 value))
              (!write (n.+ 1 idx) value))
      (#try.Success binary))
    (exception.throw ..index-out-of-bounds [(..!size binary) idx])))

(def: #export (write/32 idx value binary)
  (-> Nat (I64 Any) Binary (Try Binary))
  (if (n.< (..!size binary) (n.+ 3 idx))
    (exec (|> binary
              (!write idx (i64.logic-right-shift 24 value))
              (!write (n.+ 1 idx) (i64.logic-right-shift 16 value))
              (!write (n.+ 2 idx) (i64.logic-right-shift 8 value))
              (!write (n.+ 3 idx) value))
      (#try.Success binary))
    (exception.throw ..index-out-of-bounds [(..!size binary) idx])))

(def: #export (write/64 idx value binary)
  (-> Nat (I64 Any) Binary (Try Binary))
  (if (n.< (..!size binary) (n.+ 7 idx))
    (exec (|> binary
              (!write idx (i64.logic-right-shift 56 value))
              (!write (n.+ 1 idx) (i64.logic-right-shift 48 value))
              (!write (n.+ 2 idx) (i64.logic-right-shift 40 value))
              (!write (n.+ 3 idx) (i64.logic-right-shift 32 value))
              (!write (n.+ 4 idx) (i64.logic-right-shift 24 value))
              (!write (n.+ 5 idx) (i64.logic-right-shift 16 value))
              (!write (n.+ 6 idx) (i64.logic-right-shift 8 value))
              (!write (n.+ 7 idx) value))
      (#try.Success binary))
    (exception.throw ..index-out-of-bounds [(..!size binary) idx])))

(structure: #export equivalence
  (Equivalence Binary)
  
  (def: (= reference sample)
    (for {@.old
          (java/util/Arrays::equals reference sample)

          @.jvm
          (java/util/Arrays::equals reference sample)}
         (let [limit (!size reference)]
           (and (n.= limit
                     (!size sample))
                (loop [idx 0]
                  (if (n.< limit idx)
                    (and (n.= (!read idx reference)
                              (!read idx sample))
                         (recur (inc idx)))
                    true)))))))

(for {@.old
      (as-is)

      @.jvm
      (as-is)}

     ## Default
     (exception: #export (cannot-copy-bytes {bytes Nat}
                                            {source-input Nat}
                                            {target-output Nat})
       (exception.report
        ["Bytes" (%.nat bytes)]
        ["Source input space" (%.nat source-input)]
        ["Target output space" (%.nat target-output)])))

(def: #export (copy bytes source-offset source target-offset target)
  (-> Nat Nat Binary Nat Binary (Try Binary))
  (with-expansions [<for-jvm> (as-is (do try.monad
                                       [_ (java/lang/System::arraycopy source (.int source-offset) target (.int target-offset) (.int bytes))]
                                       (wrap target)))]
    (for {@.old
          <for-jvm>

          @.jvm
          <for-jvm>}
         
         ## Default
         (let [source-input (n.- source-offset (!size source))
               target-output (n.- target-offset (!size target))]
           (if (n.<= source-input bytes)
             (loop [idx 0]
               (if (n.< bytes idx)
                 (exec (!write (n.+ target-offset idx)
                               (!read (n.+ source-offset idx) source)
                               target)
                   (recur (inc idx)))
                 (#try.Success target)))
             (exception.throw ..cannot-copy-bytes [bytes source-input target-output]))))))

(def: #export (slice from to binary)
  (-> Nat Nat Binary (Try Binary))
  (let [size (..!size binary)]
    (if (n.<= to from)
      (if (and (n.< size from)
               (n.< size to))
        (with-expansions [<for-jvm> (as-is (#try.Success (java/util/Arrays::copyOfRange binary (.int from) (.int (inc to)))))]
          (for {@.old
                <for-jvm>

                @.jvm
                <for-jvm>}
               
               ## Default
               (let [how-many (n.- from to)]
                 (..copy how-many from binary 0 (..create how-many)))))
        (exception.throw ..slice-out-of-bounds [size from to]))
      (exception.throw ..inverted-slice [size from to]))))

(def: #export (slice' from binary)
  (-> Nat Binary (Try Binary))
  (slice from (dec (..!size binary)) binary))