Expansion for binary format.

1 files changed, 220 insertions, 124 deletions

diff --git a/stdlib/source/lux/data/format/binary.lux b/stdlib/source/lux/data/format/binary.lux
index b21887854..f6145f59f 100644
--- a/stdlib/source/lux/data/format/binary.lux
+++ b/stdlib/source/lux/data/format/binary.lux
@@ -1,20 +1,26 @@
 (.module:
   [lux (#- and or nat int rev list type)
    [control
+    [monoid (#+ Monoid)]
+    ["." fold]
     [monad (#+ do Monad)]
-    ["p" parser]
+    ["." parser (#+ Parser) ("parser/." Functor<Parser>)]
     ["ex" exception (#+ exception:)]
     [equivalence (#+ Equivalence)]]
    [data
     ["." error (#+ Error)]
-    ["." number]
+    ["." number
+     ["." i64]]
     [text
      ["." encoding]
-     [format (#+ %n)]]]
+     [format (#+ %n)]]
+    [collection
+     ["." list]
+     ["." row (#+ Row) ("row/." Functor<Row>)]]]
+   [type (#+ :share)]
    [world
     ["." binary (#+ Binary)]]])
 
-## Exceptions
 (exception: #export (binary-was-not-fully-read {length Nat} {read Nat})
   (ex.report ["Binary length" (%n length)]
              ["Read bytes" (%n read)]))
@@ -23,30 +29,61 @@
   (ex.report ["Range" (%n range)]
              ["Byte" (%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)
+(def: #export size/8 Size 1)
+(def: #export size/16 Size 2)
+(def: #export size/32 Size 4)
+(def: #export size/64 Size 8)
 
-(type: #export Read
-  (p.Parser [Offset Binary]))
+(def: mask
+  (-> Size (I64 Any))
+  (|>> (n/* i64.bits-per-byte) i64.mask))
 
-(type: #export (Write a)
-  (-> a [Size (-> Offset Binary Binary)]))
+(type: #export Reader
+  (Parser [Offset Binary]))
+
+(type: #export Mutation
+  [Size (-> Offset Binary Binary)])
+
+(def: #export no-op
+  Mutation
+  [0 (function (_ offset data) data)])
+
+(structure: #export _ (Monoid Mutation)
+  
+  (def: identity
+    ..no-op)
+  
+  (def: (compose [sizeL mutL] [sizeR mutR])
+    [(n/+ sizeL sizeR)
+     (function (_ offset data)
+       (|> data
+           (mutL offset)
+           (mutR (n/+ sizeL offset))))]))
+
+(type: #export (Writer a)
+  (-> a Mutation))
 
 (type: #export (Format a)
-  {#read (Read a)
-   #write (Write a)})
+  {#reader (Reader a)
+   #writer (Writer a)})
+
+(def: #export (adapt post-read pre-write format)
+  (All [a a']
+    (-> (-> a a')
+        (-> a' a)
+        (Format a)
+        (Format a')))
+  (let [(^open "_/.") format]
+    {#reader (|> _/reader (parser/map post-read))
+     #writer (|>> pre-write _/writer)}))
 
-## Operators
 (def: #export (read format input)
   (All [a] (-> (Format a) Binary (Error a)))
-  (case ((get@ #read format) [0 input])
+  (case ((get@ #reader format) [0 input])
     (#error.Failure msg)
     (#error.Failure msg)
     
@@ -58,26 +95,26 @@
 
 (def: #export (write format value)
   (All [a] (-> (Format a) a Binary))
-  (let [[valueS valueT] ((get@ #write format) value)]
+  (let [[valueS valueT] ((get@ #writer format) value)]
     (|> valueS binary.create (valueT 0))))
 
 ## Primitives
 (do-template [<name> <size> <read> <write>]
-  [(def: <name>
+  [(def: #export <name>
      (Format (I64 Any))
-     {#read (function (_ [offset binary])
-              (case (<read> offset binary)
-                (#error.Success data)
-                (#error.Success [(n/+ <size> offset) binary] data)
-                
-                (#error.Failure error)
-                (#error.Failure error)))
-      #write (function (_ value)
-               [<size>
-                (function (_ offset binary)
-                  (|> binary
-                      (<write> offset value)
-                      error.assume))])})]
+     {#reader (function (_ [offset binary])
+                (case (<read> offset binary)
+                  (#error.Success data)
+                  (#error.Success [(n/+ <size> offset) binary] data)
+                  
+                  (#error.Failure error)
+                  (#error.Failure error)))
+      #writer (function (_ value)
+                [<size>
+                 (function (_ offset binary)
+                   (|> binary
+                       (<write> offset value)
+                       error.assume))])})]
 
   [bits/8  size/8  binary.read/8  binary.write/8]
   [bits/16 size/16 binary.read/16 binary.write/16]
@@ -88,62 +125,59 @@
 ## Combinators
 (def: #export (or leftB rightB)
   (All [l r] (-> (Format l) (Format r) (Format (| l r))))
-  {#read (do p.Monad<Parser>
-           [flag (get@ #read bits/8)]
-           (case flag
-             0 (:: @ map (|>> #.Left) (get@ #read leftB))
-             1 (:: @ map (|>> #.Right) (get@ #read rightB))
-             _ (p.lift (ex.throw invalid-tag [2 (.nat flag)]))))
-   #write (function (_ altV)
-            (case altV
-              (#.Left leftV)
-              (let [[leftS leftT] ((get@ #write leftB) leftV)]
-                [(.inc leftS)
-                 (function (_ offset binary)
-                   (|> binary
-                       (binary.write/8 offset 0)
-                       error.assume
-                       (leftT (.inc offset))))])
-              
-              (#.Right rightV)
-              (let [[rightS rightT] ((get@ #write rightB) rightV)]
-                [(.inc rightS)
-                 (function (_ offset binary)
-                   (|> binary
-                       (binary.write/8 offset 1)
-                       error.assume
-                       (rightT (.inc offset))))])
-              ))})
+  {#reader (do parser.Monad<Parser>
+             [flag (get@ #reader bits/8)]
+             (case flag
+               0 (:: @ map (|>> #.Left) (get@ #reader leftB))
+               1 (:: @ map (|>> #.Right) (get@ #reader rightB))
+               _ (parser.lift (ex.throw invalid-tag [2 (.nat flag)]))))
+   #writer (function (_ altV)
+             (case altV
+               (#.Left leftV)
+               (let [[leftS leftT] ((get@ #writer leftB) leftV)]
+                 [(.inc leftS)
+                  (function (_ offset binary)
+                    (|> binary
+                        (binary.write/8 offset 0)
+                        error.assume
+                        (leftT (.inc offset))))])
+               
+               (#.Right rightV)
+               (let [[rightS rightT] ((get@ #writer rightB) rightV)]
+                 [(.inc rightS)
+                  (function (_ offset binary)
+                    (|> binary
+                        (binary.write/8 offset 1)
+                        error.assume
+                        (rightT (.inc offset))))])
+               ))})
 
 (def: #export (and preB postB)
   (All [a b] (-> (Format a) (Format b) (Format [a b])))
-  {#read (p.and (get@ #read preB) (get@ #read postB))
-   #write (function (_ [preV postV])
-            (let [[preS preT] ((get@ #write preB) preV)
-                  [postS postT] ((get@ #write postB) postV)]
-              [(n/+ preS postS)
-               (function (_ offset)
-                 (|>> (preT offset)
-                      (postT (n/+ preS offset))))]))})
+  {#reader (parser.and (get@ #reader preB) (get@ #reader postB))
+   #writer (function (_ [preV postV])
+             (let [[preS preT] ((get@ #writer preB) preV)
+                   [postS postT] ((get@ #writer postB) postV)]
+               [(n/+ preS postS)
+                (function (_ offset)
+                  (|>> (preT offset)
+                       (postT (n/+ preS offset))))]))})
 
 (def: #export (rec body)
   (All [a] (-> (-> (Format a) (Format a)) (Format a)))
-  {#read (function (_ input)
-           (let [read (get@ #read (body (rec body)))]
-             (read input)))
-   #write (function (_ value)
-            (let [write (get@ #write (body (rec body)))]
-              (write value)))})
-
-## Utilities
+  {#reader (function (_ input)
+             (let [reader (get@ #reader (body (rec body)))]
+               (reader input)))
+   #writer (function (_ value)
+             (let [writer (get@ #writer (body (rec body)))]
+               (writer value)))})
+
 (def: #export (ignore default)
   (All [a] (-> a (Format a)))
-  {#read (function (_ input)
-           (#error.Success [input default]))
-   #write (function (_ value)
-            [0
-             (function (_ offset binary)
-               binary)])})
+  {#reader (function (_ input)
+             (#error.Success [input default]))
+   #writer (function (_ value)
+             ..no-op)})
 
 (def: #export any
   (Format Any)
@@ -151,26 +185,26 @@
 
 (def: #export bit
   (Format Bit)
-  {#read (function (_ [offset binary])
-           (case (binary.read/8 offset binary)
-             (#error.Success data)
-             (case (: Nat data)
-               (^template [<nat> <bit>]
-                 <nat> (#error.Success [(inc offset) binary] <bit>))
-               ([0 #0]
-                [1 #1])
+  {#reader (function (_ [offset binary])
+             (case (binary.read/8 offset binary)
+               (#error.Success data)
+               (case (: Nat data)
+                 (^template [<nat> <bit>]
+                   <nat> (#error.Success [(inc offset) binary] <bit>))
+                 ([0 #0]
+                  [1 #1])
+                 
+                 _
+                 (ex.throw invalid-tag [2 data]))
                
-               _
-               (ex.throw invalid-tag [2 data]))
-             
-             (#error.Failure error)
-             (#error.Failure error)))
-   #write (function (_ value)
-            [1
-             (function (_ offset binary)
-               (|> binary
-                   (binary.write/8 offset (if value 1 0))
-                   error.assume))])})
+               (#error.Failure error)
+               (#error.Failure error)))
+   #writer (function (_ value)
+             [1
+              (function (_ offset binary)
+                (|> binary
+                    (binary.write/8 offset (if value 1 0))
+                    error.assume))])})
 
 (def: #export nat (Format Nat) (:assume ..bits/64))
 (def: #export int (Format Int) (:assume ..bits/64))
@@ -178,35 +212,97 @@
 
 (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 binary
-  (Format Binary)
-  {#read (do p.Monad<Parser>
-           [size (get@ #read nat)]
-           (function (_ [offset binary])
-             (do error.Monad<Error>
-               [#let [end (n/+ size offset)]
-                output (binary.slice offset end binary)]
-               (wrap [[end binary] output]))))
-   #write (function (_ value)
-            (let [size (binary.size value)]
-              [(n/+ size/64 size)
-               (function (_ offset binary)
-                 (error.assume
+  (let [(^slots [#reader #writer]) ..bits/64]
+    {#reader (:: parser.Monad<Parser> map number.bits-to-frac reader)
+     #writer (|>> number.frac-to-bits writer)}))
+
+(do-template [<name> <bits> <size> <write>]
+  [(def: #export <name>
+     (Format Binary)
+     {#reader (do parser.Monad<Parser>
+                [size (:coerce (Reader Nat)
+                               ## TODO: Remove coercion.
+                               (get@ #reader <bits>))]
+                (function (_ [offset binary])
                   (do error.Monad<Error>
-                    [_ (binary.write/64 offset size binary)]
-                    (binary.copy size 0 value (n/+ size/64 offset) binary))))]))})
+                    [#let [end (n/+ size offset)]
+                     output (binary.slice offset end binary)]
+                    (wrap [[end binary] output]))))
+      #writer (function (_ value)
+                (let [size (|> value
+                               binary.size
+                               (i64.and (..mask <size>)))]
+                  [(n/+ <size> size)
+                   (function (_ offset binary)
+                     (error.assume
+                      (do error.Monad<Error>
+                        [_ (<write> offset size binary)]
+                        (binary.copy size 0 value (n/+ <size> offset) binary))))]))})]
+
+  [binary/8  ..bits/8  ..size/8  binary.write/8]
+  [binary/16 ..bits/16 ..size/16 binary.write/16]
+  [binary/32 ..bits/32 ..size/32 binary.write/32]
+  [binary/64 ..bits/64 ..size/64 binary.write/64]
+  )
+
+(do-template [<name> <with-offset> <bits> <size> <write>]
+  [(def: #export (<with-offset> extra-count valueF)
+     (All [v] (-> Nat (Format v) (Format (Row v))))
+     {#reader (do parser.Monad<Parser>
+                [count (|> (get@ #reader <bits>)
+                           ## TODO: Remove coercion.
+                           (:coerce (Reader Nat))
+                           (:: @ map (n/- extra-count)))]
+                (loop [index 0
+                       output (:share [v]
+                                      {(Format v)
+                                       valueF}
+                                      {(Row v)
+                                       row.empty})]
+                  (if (n/< count index)
+                    (do parser.Monad<Parser>
+                      [value (get@ #reader valueF)]
+                      (recur (.inc index)
+                             (row.add value output)))
+                    (:: parser.Monad<Parser> wrap output))))
+      #writer (function (_ value)
+                (let [original-count (row.size value)
+                      capped-count (i64.and (..mask <size>)
+                                            original-count)
+                      value (if (n/= original-count capped-count)
+                              value
+                              (|> value row.to-list (list.take capped-count) row.from-list))
+                      (^open "mutation/.") ..Monoid<Mutation>
+                      [size mutation] (|> value
+                                          (row/map (get@ #writer valueF))
+                                          (:: row.Fold<Row> fold
+                                              (function (_ post pre)
+                                                (mutation/compose pre post))
+                                              mutation/identity))]
+                  [(n/+ <size> size)
+                   (function (_ offset binary)
+                     (error.assume
+                      (do error.Monad<Error>
+                        [_ (<write> offset (n/+ extra-count capped-count) binary)]
+                        (wrap (mutation (n/+ <size> offset) binary)))))]))})
+
+   (def: #export <name>
+     (All [v] (-> (Format v) (Format (Row v))))
+     (<with-offset> 0))]
+
+  [row/8  row/8'  ..bits/8  ..size/8  binary.write/8]
+  [row/16 row/16' ..bits/16 ..size/16 binary.write/16]
+  [row/32 row/32' ..bits/32 ..size/32 binary.write/32]
+  [row/64 row/64' ..bits/64 ..size/64 binary.write/64]
+  )
 
 (def: #export text
   (Format Text)
-  (let [(^slots [#read #write]) ..binary]
-    {#read (do p.Monad<Parser>
-             [utf8 read]
-             (p.lift (encoding.from-utf8 utf8)))
-     #write (|>> encoding.to-utf8 write)}))
+  (let [(^slots [#reader #writer]) ..binary/64]
+    {#reader (do parser.Monad<Parser>
+               [utf8 reader]
+               (parser.lift (encoding.from-utf8 utf8)))
+     #writer (|>> encoding.to-utf8 writer)}))
 
 (def: #export maybe
   (All [a] (-> (Format a) (Format (Maybe a))))