From 1b5cb7ab5ff0b774f0cd12f9504b82dae9ae977d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 5 Jul 2018 02:07:59 -0400 Subject: - Binary (de)serialization module. --- stdlib/source/lux/control/parser.lux | 12 ++- stdlib/source/lux/data/format/binary.lux | 150 +++++++++++++++++++++++++++++++ stdlib/source/lux/data/text/encoding.lux | 23 +++++ stdlib/source/lux/world/blob.jvm.lux | 97 +++++++++++--------- 4 files changed, 237 insertions(+), 45 deletions(-) create mode 100644 stdlib/source/lux/data/format/binary.lux create mode 100644 stdlib/source/lux/data/text/encoding.lux (limited to 'stdlib') 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 Monoid]) [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 [ ] + [(def: + (Format (I64 Any)) + {#read (function (_ [offset blob]) + (case ( offset blob) + (#error.Success data) + (#error.Success [(n/+ offset) blob] data) + + (#error.Error error) + (#error.Error error))) + #write (function (_ value) + [ + (function (_ offset blob) + (error.assume ( 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 [ ] + (#error.Success [(inc offset) blob] )) + ([+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 map number.bits-to-frac read) + #write (|>> number.frac-to-bits write)})) + +(def: #export blob + (Format Blob) + {#read (do p.Monad + [size (get@ #read nat)] + (function (_ [offset blob]) + (do error.Monad + [#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 + [_ (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 + [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 [ (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 ) ## 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 + [_ (System::arraycopy [source (.int source-offset) target (.int target-offset) (.int bytes)])] + (wrap target))) -- cgit v1.2.3