aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--stdlib/source/lux/control/parser.lux12
-rw-r--r--stdlib/source/lux/data/format/binary.lux150
-rw-r--r--stdlib/source/lux/data/text/encoding.lux23
-rw-r--r--stdlib/source/lux/world/blob.jvm.lux97
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)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 08:55:17 +0000