aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2017-08-22 20:32:16 -0400
committerEduardo Julian2017-08-22 20:32:16 -0400
commit9ba4a24f61dc545a7670374c05546375e4e6840d (patch)
treec732bc98d312adc97a4e7f0a8bdc31c56f49d405
parente22bc1ab2660119a26a5a77168a6566f8de3fe08 (diff)
- Implemented a blob (binary large object) library.
-rw-r--r--stdlib/source/lux/world/blob.jvm.lux138
-rw-r--r--stdlib/test/test/lux/world/blob.lux107
2 files changed, 245 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])))
diff --git a/stdlib/test/test/lux/world/blob.lux b/stdlib/test/test/lux/world/blob.lux
new file mode 100644
index 000000000..23dcd889c
--- /dev/null
+++ b/stdlib/test/test/lux/world/blob.lux
@@ -0,0 +1,107 @@
+(;module:
+ lux
+ (lux [io]
+ (control [monad #+ do]
+ [pipe])
+ (data [bit]
+ ["R" result]
+ (coll [list]))
+ (world ["@" blob])
+ ["r" math/random])
+ lux/test)
+
+(def: (succeed result)
+ (-> (R;Result Bool) Bool)
+ (case result
+ (#R;Error _)
+ false
+
+ (#R;Success output)
+ output))
+
+(def: #export (blob size)
+ (-> Nat (r;Random @;Blob))
+ (let [blob (@;create size)]
+ (do r;Monad<Random>
+ []
+ (loop [idx +0]
+ (if (n.< size idx)
+ (do @
+ [byte r;nat]
+ (exec (R;assume (@;write-8 idx byte blob))
+ (recur (n.inc idx))))
+ (wrap blob))))))
+
+(context: "Blob."
+ [blob-size (|> r;nat (:: @ map (|>. (n.% +100) (n.max +8))))
+ random-blob (blob blob-size)
+ #let [clean-blob (@;create blob-size)
+ size (@;size clean-blob)]
+ value r;nat
+ idx (|> r;nat (:: @ map (n.% size)))
+ [from to] (|> (r;list +2 (|> r;nat (:: @ map (n.% size))))
+ (:: @ map
+ (|>. (list;sort n.<)
+ (pipe;case> (^ (list from to))
+ [from to]
+
+ _
+ (undefined)))))
+ #let [value-8 (n.% (bit;shift-left +8 +1) value)
+ value-16 (n.% (bit;shift-left +16 +1) value)
+ value-32 (n.% (bit;shift-left +32 +1) value)
+ value-64 value
+ slice-size (|> to (n.- from) n.inc)
+ random-slice (R;assume (@;slice from to random-blob))]]
+ ($_ seq
+ (test "Has equality."
+ (and (:: @;Eq<Blob> = clean-blob clean-blob)
+ (:: @;Eq<Blob> =
+ (R;assume (@;slice from to clean-blob))
+ (R;assume (@;slice from to clean-blob)))))
+ (test "Can get size of blob."
+ (n.= blob-size size))
+ (test "Can read/write 8-bit values."
+ (succeed
+ (do R;Monad<Result>
+ [_ (@;write-8 idx value-8 clean-blob)
+ output-8 (@;read-8 idx clean-blob)]
+ (wrap (n.= value-8 output-8)))))
+ (test "Can read/write 16-bit values."
+ (or (n.>= size (n.+ +1 idx))
+ (succeed
+ (do R;Monad<Result>
+ [_ (@;write-16 idx value-16 clean-blob)
+ output-16 (@;read-16 idx clean-blob)]
+ (wrap (n.= value-16 output-16))))))
+ (test "Can read/write 32-bit values."
+ (or (n.>= size (n.+ +3 idx))
+ (succeed
+ (do R;Monad<Result>
+ [_ (@;write-32 idx value-32 clean-blob)
+ output-32 (@;read-32 idx clean-blob)]
+ (wrap (n.= value-32 output-32))))))
+ (test "Can read/write 64-bit values."
+ (or (n.>= size (n.+ +7 idx))
+ (succeed
+ (do R;Monad<Result>
+ [_ (@;write-64 idx value-64 clean-blob)
+ output-64 (@;read-64 idx clean-blob)]
+ (wrap (n.= value-64 output-64))))))
+ (test "Can slice blobs."
+ (and (n.= slice-size (@;size random-slice))
+ (loop [idx +0]
+ (let [loop-recur recur]
+ (if (n.< slice-size idx)
+ (and (succeed
+ (do R;Monad<Result>
+ [reference (@;read-8 (n.+ from idx) random-blob)
+ sample (@;read-8 idx random-slice)]
+ (wrap (n.= reference sample))))
+ (loop-recur (n.inc idx)))
+ true)))))
+ (test "Slicing the whole blob does not change anything."
+ (:: @;Eq<Blob> =
+ random-blob
+ (R;assume (@;slice +0 (n.dec blob-size) random-blob))))
+ ))