- Implemented a blob (binary large object) library.

1 files changed, 138 insertions, 0 deletions

diff --git a/stdlib/source/lux/world/blob.jvm.lux b/stdlib/source/lux/world/blob.jvm.lux
new file mode 100644
index 000000000..66d4d4a13
--- /dev/null
+++ b/stdlib/source/lux/world/blob.jvm.lux
@@ -0,0 +1,138 @@
+(;module:
+  lux
+  (lux (control [monad #+ do]
+                ["ex" exception #+ exception:]
+                [eq])
+       (data [bit]
+             [maybe]
+             ["R" result]
+             text/format)
+       [host #+ jvm-import]))
+
+(exception: #export Index-Out-Of-Bounds)
+(exception: #export Inverted-Range)
+
+(type: #export Blob host;Byte-Array)
+
+(jvm-import java.util.Arrays
+  (#static copyOfRange [Byte-Array int int] Byte-Array)
+  (#static equals [Byte-Array Byte-Array] boolean))
+
+(def: byte-mask
+  Nat
+  (|> +1 (bit;shift-left +8) n.dec))
+
+(def: byte-to-nat
+  (-> (host java.lang.Byte) Nat)
+  (|>. host;b2l (:! Nat) (bit;and byte-mask)))
+
+(def: #export (create size)
+  (-> Nat Blob)
+  (host;array byte size))
+
+(def: #export (read-8 idx blob)
+  (-> Nat Blob (R;Result Nat))
+  (if (n.< (host;array-length blob) idx)
+    (|> (host;array-read idx blob) byte-to-nat #R;Success)
+    (ex;throw Index-Out-Of-Bounds (%n idx))))
+
+(def: #export (read-16 idx blob)
+  (-> Nat Blob (R;Result Nat))
+  (if (n.< (host;array-length blob) (n.+ +1 idx))
+    (#R;Success ($_ bit;or
+                    (bit;shift-left +8 (byte-to-nat (host;array-read idx blob)))
+                    (byte-to-nat (host;array-read (n.+ +1 idx) blob))))
+    (ex;throw Index-Out-Of-Bounds (%n idx))))
+
+(def: #export (read-32 idx blob)
+  (-> Nat Blob (R;Result Nat))
+  (if (n.< (host;array-length blob) (n.+ +3 idx))
+    (#R;Success ($_ bit;or
+                    (bit;shift-left +24 (byte-to-nat (host;array-read idx blob)))
+                    (bit;shift-left +16 (byte-to-nat (host;array-read (n.+ +1 idx) blob)))
+                    (bit;shift-left +8 (byte-to-nat (host;array-read (n.+ +2 idx) blob)))
+                    (byte-to-nat (host;array-read (n.+ +3 idx) blob))))
+    (ex;throw Index-Out-Of-Bounds (%n idx))))
+
+(def: #export (read-64 idx blob)
+  (-> Nat Blob (R;Result Nat))
+  (if (n.< (host;array-length blob) (n.+ +7 idx))
+    (#R;Success ($_ bit;or
+                    (bit;shift-left +56 (byte-to-nat (host;array-read idx blob)))
+                    (bit;shift-left +48 (byte-to-nat (host;array-read (n.+ +1 idx) blob)))
+                    (bit;shift-left +40 (byte-to-nat (host;array-read (n.+ +2 idx) blob)))
+                    (bit;shift-left +32 (byte-to-nat (host;array-read (n.+ +3 idx) blob)))
+                    (bit;shift-left +24 (byte-to-nat (host;array-read (n.+ +4 idx) blob)))
+                    (bit;shift-left +16 (byte-to-nat (host;array-read (n.+ +5 idx) blob)))
+                    (bit;shift-left +8 (byte-to-nat (host;array-read (n.+ +6 idx) blob)))
+                    (byte-to-nat (host;array-read (n.+ +7 idx) blob))))
+    (ex;throw Index-Out-Of-Bounds (%n idx))))
+
+(def: #export (write-8 idx value blob)
+  (-> Nat Nat Blob (R;Result Unit))
+  (if (n.< (host;array-length blob) idx)
+    (exec (|> blob
+              (host;array-write idx (host;l2b (:! Int value))))
+      (#R;Success []))
+    (ex;throw Index-Out-Of-Bounds (%n idx))))
+
+(def: #export (write-16 idx value blob)
+  (-> Nat Nat Blob (R;Result Unit))
+  (if (n.< (host;array-length blob) (n.+ +1 idx))
+    (exec (|> blob
+              (host;array-write idx (host;l2b (:! Int (bit;unsigned-shift-right +8 value))))
+              (host;array-write (n.+ +1 idx) (host;l2b (:! Int value))))
+      (#R;Success []))
+    (ex;throw Index-Out-Of-Bounds (%n idx))))
+
+(def: #export (write-32 idx value blob)
+  (-> Nat Nat Blob (R;Result Unit))
+  (if (n.< (host;array-length blob) (n.+ +3 idx))
+    (exec (|> blob
+              (host;array-write idx (host;l2b (:! Int (bit;unsigned-shift-right +24 value))))
+              (host;array-write (n.+ +1 idx) (host;l2b (:! Int (bit;unsigned-shift-right +16 value))))
+              (host;array-write (n.+ +2 idx) (host;l2b (:! Int (bit;unsigned-shift-right +8 value))))
+              (host;array-write (n.+ +3 idx) (host;l2b (:! Int value))))
+      (#R;Success []))
+    (ex;throw Index-Out-Of-Bounds (%n idx))))
+
+(def: #export (write-64 idx value blob)
+  (-> Nat Nat Blob (R;Result Unit))
+  (if (n.< (host;array-length blob) (n.+ +7 idx))
+    (exec (|> blob
+              (host;array-write idx (host;l2b (:! Int (bit;unsigned-shift-right +56 value))))
+              (host;array-write (n.+ +1 idx) (host;l2b (:! Int (bit;unsigned-shift-right +48 value))))
+              (host;array-write (n.+ +2 idx) (host;l2b (:! Int (bit;unsigned-shift-right +40 value))))
+              (host;array-write (n.+ +3 idx) (host;l2b (:! Int (bit;unsigned-shift-right +32 value))))
+              (host;array-write (n.+ +4 idx) (host;l2b (:! Int (bit;unsigned-shift-right +24 value))))
+              (host;array-write (n.+ +5 idx) (host;l2b (:! Int (bit;unsigned-shift-right +16 value))))
+              (host;array-write (n.+ +6 idx) (host;l2b (:! Int (bit;unsigned-shift-right +8 value))))
+              (host;array-write (n.+ +7 idx) (host;l2b (:! Int value))))
+      (#R;Success []))
+    (ex;throw Index-Out-Of-Bounds (%n idx))))
+
+(def: #export (size blob)
+  (-> Blob Nat)
+  (host;array-length blob))
+
+(def: #export (slice from to blob)
+  (-> Nat Nat Blob (R;Result Blob))
+  (with-expansions [<description> (as-is (format "from = " (%n from) " | " "to = " (%n to)))]
+    (let [size (host;array-length blob)]
+      (cond (not (n.<= to from))
+            (ex;throw Inverted-Range <description>)
+
+            (not (and (n.< size from)
+                      (n.< size to)))
+            (ex;throw Index-Out-Of-Bounds <description>)
+
+            ## else
+            (#R;Success (Arrays.copyOfRange [blob (:! Int from) (:! Int (n.inc to))]))))))
+
+(def: #export (slice' from blob)
+  (-> Nat Blob (R;Result Blob))
+  (slice from (n.dec (host;array-length blob)) blob))
+
+(struct: #export _ (eq;Eq Blob)
+  (def: (= reference sample)
+    (Arrays.equals [reference sample])))