aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/library/lux/control/parser/binary.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/library/lux/control/parser/binary.lux')
-rw-r--r--stdlib/source/library/lux/control/parser/binary.lux275
1 files changed, 275 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/control/parser/binary.lux b/stdlib/source/library/lux/control/parser/binary.lux
new file mode 100644
index 000000000..af28caeae
--- /dev/null
+++ b/stdlib/source/library/lux/control/parser/binary.lux
@@ -0,0 +1,275 @@
+(.module:
+ [library
+ [lux (#- and or nat int rev list type)
+ [type (#+ :share)]
+ [abstract
+ [hash (#+ Hash)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ ["/" binary (#+ Binary)]
+ [text
+ ["%" format (#+ format)]
+ [encoding
+ ["." utf8]]]
+ [collection
+ ["." list]
+ ["." row (#+ Row)]
+ ["." set (#+ Set)]]]
+ [macro
+ ["." template]]
+ [math
+ [number
+ ["n" nat]
+ ["." frac]]]]]
+ ["." // ("#\." monad)])
+
+(type: #export Offset Nat)
+
+(type: #export Parser
+ (//.Parser [Offset Binary]))
+
+(exception: #export (binary_was_not_fully_read {binary_length Nat} {bytes_read Nat})
+ (exception.report
+ ["Binary length" (%.nat binary_length)]
+ ["Bytes read" (%.nat bytes_read)]))
+
+(def: #export (run parser input)
+ (All [a] (-> (Parser a) Binary (Try a)))
+ (case (parser [0 input])
+ (#try.Failure msg)
+ (#try.Failure msg)
+
+ (#try.Success [[end _] output])
+ (let [length (/.size input)]
+ (if (n.= end length)
+ (#try.Success output)
+ (exception.throw ..binary_was_not_fully_read [length end])))))
+
+(def: #export end?
+ (Parser Bit)
+ (function (_ (^@ input [offset data]))
+ (#try.Success [input (n.= offset (/.size data))])))
+
+(def: #export offset
+ (Parser Offset)
+ (function (_ (^@ input [offset data]))
+ (#try.Success [input offset])))
+
+(def: #export remaining
+ (Parser Nat)
+ (function (_ (^@ input [offset data]))
+ (#try.Success [input (n.- offset (/.size data))])))
+
+(type: #export Size Nat)
+
+(def: #export size/8 Size 1)
+(def: #export size/16 Size (n.* 2 size/8))
+(def: #export size/32 Size (n.* 2 size/16))
+(def: #export size/64 Size (n.* 2 size/32))
+
+(template [<name> <size> <read>]
+ [(def: #export <name>
+ (Parser I64)
+ (function (_ [offset binary])
+ (case (<read> offset binary)
+ (#try.Success data)
+ (#try.Success [(n.+ <size> offset) binary] data)
+
+ (#try.Failure error)
+ (#try.Failure error))))]
+
+ [bits/8 ..size/8 /.read/8]
+ [bits/16 ..size/16 /.read/16]
+ [bits/32 ..size/32 /.read/32]
+ [bits/64 ..size/64 /.read/64]
+ )
+
+(template [<name> <type>]
+ [(def: #export <name> (Parser <type>) ..bits/64)]
+
+ [nat Nat]
+ [int Int]
+ [rev Rev]
+ )
+
+(def: #export frac
+ (Parser Frac)
+ (//\map frac.from_bits ..bits/64))
+
+(exception: #export (invalid_tag {range Nat} {byte Nat})
+ (exception.report
+ ["Tag range" (%.nat range)]
+ ["Tag value" (%.nat byte)]))
+
+(template: (!variant <case>+)
+ (do {! //.monad}
+ [flag (: (Parser Nat)
+ ..bits/8)]
+ (`` (case flag
+ (^template [<number> <tag> <parser>]
+ [<number> (\ ! map (|>> <tag>) <parser>)])
+ ((~~ (template.splice <case>+)))
+ _ (//.lift (exception.throw ..invalid_tag [(~~ (template.count <case>+)) flag]))))))
+
+(def: #export (or left right)
+ (All [l r] (-> (Parser l) (Parser r) (Parser (| l r))))
+ (!variant [[0 #.Left left]
+ [1 #.Right right]]))
+
+(def: #export (rec body)
+ (All [a] (-> (-> (Parser a) (Parser a)) (Parser a)))
+ (function (_ input)
+ (let [parser (body (rec body))]
+ (parser input))))
+
+(def: #export any
+ (Parser Any)
+ (//\wrap []))
+
+(exception: #export (not_a_bit {value Nat})
+ (exception.report
+ ["Expected values" "either 0 or 1"]
+ ["Actual value" (%.nat value)]))
+
+(def: #export bit
+ (Parser Bit)
+ (do //.monad
+ [value (: (Parser Nat)
+ ..bits/8)]
+ (case value
+ 0 (wrap #0)
+ 1 (wrap #1)
+ _ (//.lift (exception.throw ..not_a_bit [value])))))
+
+(def: #export (segment size)
+ (-> Nat (Parser Binary))
+ (function (_ [offset binary])
+ (case size
+ 0 (#try.Success [[offset binary] (/.create 0)])
+ _ (|> binary
+ (/.slice offset size)
+ (\ try.monad map (|>> [[(n.+ size offset) binary]]))))))
+
+(template [<name> <bits>]
+ [(def: #export <name>
+ (Parser Binary)
+ (do //.monad
+ [size (//\map .nat <bits>)]
+ (..segment size)))]
+
+ [binary/8 ..bits/8]
+ [binary/16 ..bits/16]
+ [binary/32 ..bits/32]
+ [binary/64 ..bits/64]
+ )
+
+(template [<name> <binary>]
+ [(def: #export <name>
+ (Parser Text)
+ (do //.monad
+ [utf8 <binary>]
+ (//.lift (\ utf8.codec decode utf8))))]
+
+ [utf8/8 ..binary/8]
+ [utf8/16 ..binary/16]
+ [utf8/32 ..binary/32]
+ [utf8/64 ..binary/64]
+ )
+
+(def: #export text ..utf8/64)
+
+(template [<name> <bits>]
+ [(def: #export (<name> valueP)
+ (All [v] (-> (Parser v) (Parser (Row v))))
+ (do //.monad
+ [count (: (Parser Nat)
+ <bits>)]
+ (loop [index 0
+ output (:share [v]
+ (Parser v)
+ valueP
+
+ (Row v)
+ row.empty)]
+ (if (n.< count index)
+ (do //.monad
+ [value valueP]
+ (recur (.inc index)
+ (row.add value output)))
+ (//\wrap output)))))]
+
+ [row/8 ..bits/8]
+ [row/16 ..bits/16]
+ [row/32 ..bits/32]
+ [row/64 ..bits/64]
+ )
+
+(def: #export maybe
+ (All [a] (-> (Parser a) (Parser (Maybe a))))
+ (..or ..any))
+
+(def: #export (list value)
+ (All [a] (-> (Parser a) (Parser (List a))))
+ (..rec
+ (|>> (//.and value)
+ (..or ..any))))
+
+(exception: #export set_elements_are_not_unique)
+
+(def: #export (set hash value)
+ (All [a] (-> (Hash a) (Parser a) (Parser (Set a))))
+ (do //.monad
+ [raw (..list value)
+ #let [output (set.from_list hash raw)]
+ _ (//.assert (exception.construct ..set_elements_are_not_unique [])
+ (n.= (list.size raw)
+ (set.size output)))]
+ (wrap output)))
+
+(def: #export name
+ (Parser Name)
+ (//.and ..text ..text))
+
+(def: #export type
+ (Parser Type)
+ (..rec
+ (function (_ type)
+ (let [pair (//.and type type)
+ indexed ..nat
+ quantified (//.and (..list type) type)]
+ (!variant [[0 #.Primitive (//.and ..text (..list type))]
+ [1 #.Sum pair]
+ [2 #.Product pair]
+ [3 #.Function pair]
+ [4 #.Parameter indexed]
+ [5 #.Var indexed]
+ [6 #.Ex indexed]
+ [7 #.UnivQ quantified]
+ [8 #.ExQ quantified]
+ [9 #.Apply pair]
+ [10 #.Named (//.and ..name type)]])))))
+
+(def: #export location
+ (Parser Location)
+ ($_ //.and ..text ..nat ..nat))
+
+(def: #export code
+ (Parser Code)
+ (..rec
+ (function (_ recur)
+ (let [sequence (..list recur)]
+ (//.and ..location
+ (!variant [[0 #.Bit ..bit]
+ [1 #.Nat ..nat]
+ [2 #.Int ..int]
+ [3 #.Rev ..rev]
+ [4 #.Frac ..frac]
+ [5 #.Text ..text]
+ [6 #.Identifier ..name]
+ [7 #.Tag ..name]
+ [8 #.Form sequence]
+ [9 #.Tuple sequence]
+ [10 #.Record (..list (//.and recur recur))]]))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-24 11:57:17 +0000