- Binary (de)serialization module.

4 files changed, 237 insertions, 45 deletions

diff --git a/stdlib/source/lux/control/parser.lux b/stdlib/source/lux/control/parser.lux
index 14c6c3313..91c3a84a8 100644
--- a/stdlib/source/lux/control/parser.lux
+++ b/stdlib/source/lux/control/parser.lux
@@ -6,7 +6,7 @@
                 [codec])
        (data (coll [list "list/" Functor<List> Monoid<List>])
              [product]
-             ["e" error])))
+             ["e" error #+ Error])))
 
 (type: #export (Parser s a)
   {#.doc "A generic parser."}
@@ -206,6 +206,16 @@
   (function (_ input)
     (#e.Error message)))
 
+(def: #export (lift operation)
+  (All [s a] (-> (Error a) (Parser s a)))
+  (function (_ input)
+    (case operation
+      (#e.Success output)
+      (#e.Success [input output])
+      
+      (#e.Error error)
+      (#e.Error error))))
+
 (def: #export (default value parser)
   {#.doc "If the given parser fails, returns the default value."}
   (All [s a] (-> a (Parser s a) (Parser s a)))
diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux
new file mode 100644
index 000000000..cabdf7091
--- /dev/null
+++ b/stdlib/source/lux/data/format/binary.lux
@@ -0,0 +1,150 @@
+(.module:
+  [lux #- nat int rev]
+  (lux (control [monad #+ do Monad]
+                ["p" parser]
+                ["ex" exception #+ exception:])
+       (data [error]
+             (text [encoding]
+                   [format #+ %n])
+             [number])
+       (world [blob #+ Blob])))
+
+## Exceptions
+(exception: #export (blob-was-not-fully-read {length Nat} {read Nat})
+  (ex.report ["Blob length" (%n length)]
+             ["Read bytes" (%n read)]))
+
+(exception: #export (invalid-bool {byte Nat})
+  (%n byte))
+
+## Types
+(type: #export Offset Nat)
+
+(type: #export Size Nat)
+
+(def: #export size/8 +1)
+(def: #export size/16 +2)
+(def: #export size/32 +4)
+(def: #export size/64 +8)
+
+(type: #export Read
+  (p.Parser [Offset Blob]))
+
+(type: #export (Write a)
+  (-> a [Size (-> Offset Blob Blob)]))
+
+(type: #export (Format a)
+  {#read (Read a)
+   #write (Write a)})
+
+## Operators
+(def: #export (read format input)
+  (All [a] (-> (Format a) Blob (error.Error a)))
+  (case ((get@ #read format) [+0 input])
+    (#error.Error msg)
+    (#error.Error msg)
+    
+    (#error.Success [[end _] output])
+    (let [length (blob.size input)]
+      (if (n/= end length)
+        (#error.Success output)
+        (ex.throw blob-was-not-fully-read [length end])))))
+
+(def: #export (write format value)
+  (All [a] (-> (Format a) a Blob))
+  (let [[valueS valueT] ((get@ #write format) value)]
+    (|> valueS blob.create (valueT +0))))
+
+## Combinators
+(def: #export (seq preF postF)
+  (All [a b] (-> (Format a) (Format b) (Format [a b])))
+  {#read (p.seq (get@ #read preF) (get@ #read postF))
+   #write (function (_ [preV postV])
+            (let [[preS preT] ((get@ #write preF) preV)
+                  [postS postT] ((get@ #write postF) postV)]
+              [(n/+ preS postS)
+               (function (_ offset)
+                 (|>> (preT offset)
+                      (postT (n/+ preS offset))))]))})
+
+## Primitives
+(do-template [<name> <size> <read> <write>]
+  [(def: <name>
+     (Format (I64 Any))
+     {#read (function (_ [offset blob])
+              (case (<read> offset blob)
+                (#error.Success data)
+                (#error.Success [(n/+ <size> offset) blob] data)
+                
+                (#error.Error error)
+                (#error.Error error)))
+      #write (function (_ value)
+               [<size>
+                (function (_ offset blob)
+                  (error.assume (<write> offset value blob)))])})]
+
+  [bits/8  size/8 blob.read/8  blob.write/8]
+  [bits/16 size/16 blob.read/16 blob.write/16]
+  [bits/32 size/32 blob.read/32 blob.write/32]
+  [bits/64 size/64 blob.read/64 blob.write/64]
+  )
+
+## Utilities
+(def: #export bool
+  (Format Bool)
+  {#read (function (_ [offset blob])
+           (case (blob.read/8 offset blob)
+             (#error.Success data)
+             (case (: Nat data)
+               (^template [<nat> <bool>]
+                 <nat> (#error.Success [(inc offset) blob] <bool>))
+               ([+0 false]
+                [+1 true])
+               
+               _
+               (ex.throw invalid-bool data))
+             
+             (#error.Error error)
+             (#error.Error error)))
+   #write (function (_ value)
+            [+1
+             (function (_ offset blob)
+               (exec (error.assume (blob.write/8 offset (if value +1 +0) blob))
+                 blob))])}
+  )
+
+(def: #export nat (Format Nat) (:assume ..bits/64))
+(def: #export int (Format Int) (:assume ..bits/64))
+(def: #export rev (Format Rev) (:assume ..bits/64))
+
+(def: #export frac
+  (Format Frac)
+  (let [(^slots [#read #write]) ..bits/64]
+    {#read (:: p.Monad<Parser> map number.bits-to-frac read)
+     #write (|>> number.frac-to-bits write)}))
+
+(def: #export blob
+  (Format Blob)
+  {#read (do p.Monad<Parser>
+           [size (get@ #read nat)]
+           (function (_ [offset blob])
+             (do error.Monad<Error>
+               [#let [end (n/+ size offset)]
+                output (blob.slice offset end blob)]
+               (wrap [[end blob] output]))))
+   #write (function (_ value)
+            (let [size (blob.size value)]
+              [(n/+ size/64 size)
+               (function (_ offset blob)
+                 (error.assume
+                  (do error.Monad<Error>
+                    [_ (blob.write/64 offset size blob)]
+                    (blob.copy size +0 value (n/+ size/64 offset) blob))))]))})
+
+(def: #export text
+  (Format Text)
+  (let [(^slots [#read #write]) ..blob]
+    {#read (do p.Monad<Parser>
+             [utf8 read]
+             (p.lift (encoding.from-utf8 utf8)))
+     #write (|>> encoding.to-utf8 write)}))
diff --git a/stdlib/source/lux/data/text/encoding.lux b/stdlib/source/lux/data/text/encoding.lux
new file mode 100644
index 000000000..eb3b618c4
--- /dev/null
+++ b/stdlib/source/lux/data/text/encoding.lux
@@ -0,0 +1,23 @@
+(.module:
+  lux
+  (lux (data [error #+ Error])
+       (world [blob #+ Blob])
+       (lang ["_" host])
+       [host #+ import:]))
+
+(`` (for {(~~ (static _.jvm))
+          (as-is (def: utf8 Text "UTF-8")
+
+                 (import: java/lang/String
+                   (new [(Array byte) String])
+                   (getBytes [String] (Array byte))))}))
+
+(def: #export (to-utf8 value)
+  (-> Text Blob)
+  (`` (for {(~~ (static _.jvm))
+            (String::getBytes [..utf8] value)})))
+
+(def: #export (from-utf8 value)
+  (-> Blob (Error Text))
+  (`` (for {(~~ (static _.jvm))
+            (#error.Success (String::new [value ..utf8]))})))
diff --git a/stdlib/source/lux/world/blob.jvm.lux b/stdlib/source/lux/world/blob.jvm.lux
index 162574ba9..452dc9db5 100644
--- a/stdlib/source/lux/world/blob.jvm.lux
+++ b/stdlib/source/lux/world/blob.jvm.lux
@@ -5,9 +5,9 @@
                 ["eq" equivalence])
        (data [bit]
              [maybe]
-             ["e" error]
+             [error #+ Error]
              text/format)
-       [host]))
+       [host #+ import:]))
 
 (exception: #export (index-out-of-bounds {description Text})
   description)
@@ -17,7 +17,10 @@
 
 (type: #export Blob (host.type (Array byte)))
 
-(host.import: java/util/Arrays
+(import: java/lang/System
+  (#static arraycopy [Object int Object int int] #try void))
+
+(import: java/util/Arrays
   (#static copyOfRange [(Array byte) int int] (Array byte))
   (#static equals [(Array byte) (Array byte)] boolean))
 
@@ -37,74 +40,74 @@
   (-> Nat Blob)
   (host.array byte size))
 
-(def: #export (read-8 idx blob)
-  (-> Nat Blob (e.Error I64))
+(def: #export (read/8 idx blob)
+  (-> Nat Blob (Error I64))
   (if (n/< (host.array-length blob) idx)
-    (|> (host.array-read idx blob) ..i64 #e.Success)
+    (|> (host.array-read idx blob) ..i64 #error.Success)
     (ex.throw index-out-of-bounds (%n idx))))
 
-(def: #export (read-16 idx blob)
-  (-> Nat Blob (e.Error I64))
+(def: #export (read/16 idx blob)
+  (-> Nat Blob (Error I64))
   (if (n/< (host.array-length blob) (n/+ +1 idx))
-    (#e.Success ($_ bit.or
-                    (bit.left-shift +8 (..i64 (host.array-read idx blob)))
-                    (..i64 (host.array-read (n/+ +1 idx) blob))))
+    (#error.Success ($_ bit.or
+                        (bit.left-shift +8 (..i64 (host.array-read idx blob)))
+                        (..i64 (host.array-read (n/+ +1 idx) blob))))
     (ex.throw index-out-of-bounds (%n idx))))
 
-(def: #export (read-32 idx blob)
-  (-> Nat Blob (e.Error I64))
+(def: #export (read/32 idx blob)
+  (-> Nat Blob (Error I64))
   (if (n/< (host.array-length blob) (n/+ +3 idx))
-    (#e.Success ($_ bit.or
-                    (bit.left-shift +24 (..i64 (host.array-read idx blob)))
-                    (bit.left-shift +16 (..i64 (host.array-read (n/+ +1 idx) blob)))
-                    (bit.left-shift +8 (..i64 (host.array-read (n/+ +2 idx) blob)))
-                    (..i64 (host.array-read (n/+ +3 idx) blob))))
+    (#error.Success ($_ bit.or
+                        (bit.left-shift +24 (..i64 (host.array-read idx blob)))
+                        (bit.left-shift +16 (..i64 (host.array-read (n/+ +1 idx) blob)))
+                        (bit.left-shift +8 (..i64 (host.array-read (n/+ +2 idx) blob)))
+                        (..i64 (host.array-read (n/+ +3 idx) blob))))
     (ex.throw index-out-of-bounds (%n idx))))
 
-(def: #export (read-64 idx blob)
-  (-> Nat Blob (e.Error I64))
+(def: #export (read/64 idx blob)
+  (-> Nat Blob (Error I64))
   (if (n/< (host.array-length blob) (n/+ +7 idx))
-    (#e.Success ($_ bit.or
-                    (bit.left-shift +56 (..i64 (host.array-read idx blob)))
-                    (bit.left-shift +48 (..i64 (host.array-read (n/+ +1 idx) blob)))
-                    (bit.left-shift +40 (..i64 (host.array-read (n/+ +2 idx) blob)))
-                    (bit.left-shift +32 (..i64 (host.array-read (n/+ +3 idx) blob)))
-                    (bit.left-shift +24 (..i64 (host.array-read (n/+ +4 idx) blob)))
-                    (bit.left-shift +16 (..i64 (host.array-read (n/+ +5 idx) blob)))
-                    (bit.left-shift +8 (..i64 (host.array-read (n/+ +6 idx) blob)))
-                    (..i64 (host.array-read (n/+ +7 idx) blob))))
+    (#error.Success ($_ bit.or
+                        (bit.left-shift +56 (..i64 (host.array-read idx blob)))
+                        (bit.left-shift +48 (..i64 (host.array-read (n/+ +1 idx) blob)))
+                        (bit.left-shift +40 (..i64 (host.array-read (n/+ +2 idx) blob)))
+                        (bit.left-shift +32 (..i64 (host.array-read (n/+ +3 idx) blob)))
+                        (bit.left-shift +24 (..i64 (host.array-read (n/+ +4 idx) blob)))
+                        (bit.left-shift +16 (..i64 (host.array-read (n/+ +5 idx) blob)))
+                        (bit.left-shift +8 (..i64 (host.array-read (n/+ +6 idx) blob)))
+                        (..i64 (host.array-read (n/+ +7 idx) blob))))
     (ex.throw index-out-of-bounds (%n idx))))
 
-(def: #export (write-8 idx value blob)
-  (-> Nat (I64 Any) Blob (e.Error Blob))
+(def: #export (write/8 idx value blob)
+  (-> Nat (I64 Any) Blob (Error Blob))
   (if (n/< (host.array-length blob) idx)
     (exec (|> blob
               (host.array-write idx (..byte value)))
-      (#e.Success blob))
+      (#error.Success blob))
     (ex.throw index-out-of-bounds (%n idx))))
 
-(def: #export (write-16 idx value blob)
-  (-> Nat (I64 Any) Blob (e.Error Blob))
+(def: #export (write/16 idx value blob)
+  (-> Nat (I64 Any) Blob (Error Blob))
   (if (n/< (host.array-length blob) (n/+ +1 idx))
     (exec (|> blob
               (host.array-write idx (..byte (bit.logical-right-shift +8 value)))
               (host.array-write (n/+ +1 idx) (..byte value)))
-      (#e.Success blob))
+      (#error.Success blob))
     (ex.throw index-out-of-bounds (%n idx))))
 
-(def: #export (write-32 idx value blob)
-  (-> Nat (I64 Any) Blob (e.Error Blob))
+(def: #export (write/32 idx value blob)
+  (-> Nat (I64 Any) Blob (Error Blob))
   (if (n/< (host.array-length blob) (n/+ +3 idx))
     (exec (|> blob
               (host.array-write idx (..byte (bit.logical-right-shift +24 value)))
               (host.array-write (n/+ +1 idx) (..byte (bit.logical-right-shift +16 value)))
               (host.array-write (n/+ +2 idx) (..byte (bit.logical-right-shift +8 value)))
               (host.array-write (n/+ +3 idx) (..byte value)))
-      (#e.Success blob))
+      (#error.Success blob))
     (ex.throw index-out-of-bounds (%n idx))))
 
-(def: #export (write-64 idx value blob)
-  (-> Nat (I64 Any) Blob (e.Error Blob))
+(def: #export (write/64 idx value blob)
+  (-> Nat (I64 Any) Blob (Error Blob))
   (if (n/< (host.array-length blob) (n/+ +7 idx))
     (exec (|> blob
               (host.array-write idx (..byte (bit.logical-right-shift +56 value)))
@@ -115,7 +118,7 @@
               (host.array-write (n/+ +5 idx) (..byte (bit.logical-right-shift +16 value)))
               (host.array-write (n/+ +6 idx) (..byte (bit.logical-right-shift +8 value)))
               (host.array-write (n/+ +7 idx) (..byte value)))
-      (#e.Success blob))
+      (#error.Success blob))
     (ex.throw index-out-of-bounds (%n idx))))
 
 (def: #export (size blob)
@@ -123,7 +126,7 @@
   (host.array-length blob))
 
 (def: #export (slice from to blob)
-  (-> Nat Nat Blob (e.Error Blob))
+  (-> Nat Nat Blob (Error Blob))
   (with-expansions [<description> (as-is (format "from = " (%n from) " | " "to = " (%n to)))]
     (let [size (host.array-length blob)]
       (cond (not (n/<= to from))
@@ -134,12 +137,18 @@
             (ex.throw index-out-of-bounds <description>)
 
             ## else
-            (#e.Success (Arrays::copyOfRange [blob (:coerce Int from) (:coerce Int (inc to))]))))))
+            (#error.Success (Arrays::copyOfRange [blob (:coerce Int from) (:coerce Int (inc to))]))))))
 
 (def: #export (slice' from blob)
-  (-> Nat Blob (e.Error Blob))
+  (-> Nat Blob (Error Blob))
   (slice from (dec (host.array-length blob)) blob))
 
 (struct: #export _ (eq.Equivalence Blob)
   (def: (= reference sample)
     (Arrays::equals [reference sample])))
+
+(def: #export (copy bytes source-offset source target-offset target)
+  (-> Nat Nat Blob Nat Blob (Error Blob))
+  (do error.Monad<Error>
+    [_ (System::arraycopy [source (.int source-offset) target (.int target-offset) (.int bytes)])]
+    (wrap target)))