diff options
| -rw-r--r-- | stdlib/source/lux/world/blob.jvm.lux | 138 | ||||
| -rw-r--r-- | stdlib/test/test/lux/world/blob.lux | 107 |
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)))) + )) |