path: root/stdlib/source/lux/data/format/binary.lux

(.module:
  [lux (#- and or nat int rev list type)
   [control
    [monoid (#+ Monoid)]
    ["." fold]
    [monad (#+ do Monad)]
    ["." parser (#+ Parser) ("parser/." Functor<Parser>)]
    ["ex" exception (#+ exception:)]
    [equivalence (#+ Equivalence)]]
   [data
    ["." error (#+ Error)]
    ["." number
     ["." i64]]
    [text
     ["." encoding]
     [format (#+ %n)]]
    [collection
     ["." list]
     ["." row (#+ Row) ("row/." Functor<Row>)]]]
   [type (#+ :share)]
   [world
    ["." binary (#+ Binary)]]])

(exception: #export (binary-was-not-fully-read {length Nat} {read Nat})
  (ex.report ["Binary length" (%n length)]
             ["Read bytes" (%n read)]))

(exception: #export (invalid-tag {range Nat} {byte Nat})
  (ex.report ["Range" (%n range)]
             ["Byte" (%n byte)]))

(type: #export Offset Nat)

(type: #export Size Nat)

(def: #export size/8 Size 1)
(def: #export size/16 Size 2)
(def: #export size/32 Size 4)
(def: #export size/64 Size 8)

(def: mask
  (-> Size (I64 Any))
  (|>> (n/* i64.bits-per-byte) i64.mask))

(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)
  {#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)}))

(def: #export (read format input)
  (All [a] (-> (Format a) Binary (Error a)))
  (case ((get@ #reader format) [0 input])
    (#error.Failure msg)
    (#error.Failure msg)
    
    (#error.Success [[end _] output])
    (let [length (binary.size input)]
      (if (n/= end length)
        (#error.Success output)
        (ex.throw binary-was-not-fully-read [length end])))))

(def: #export (write format value)
  (All [a] (-> (Format a) a Binary))
  (let [[valueS valueT] ((get@ #writer format) value)]
    (|> valueS binary.create (valueT 0))))

## Primitives
(do-template [<name> <size> <read> <write>]
  [(def: #export <name>
     (Format (I64 Any))
     {#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]
  [bits/32 size/32 binary.read/32 binary.write/32]
  [bits/64 size/64 binary.read/64 binary.write/64]
  )

## Combinators
(def: #export (or leftB rightB)
  (All [l r] (-> (Format l) (Format r) (Format (| l r))))
  {#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])))
  {#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)))
  {#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)))
  {#reader (function (_ input)
             (#error.Success [input default]))
   #writer (function (_ value)
             ..no-op)})

(def: #export any
  (Format Any)
  (ignore []))

(def: #export bit
  (Format Bit)
  {#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]))
               
               (#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))
(def: #export rev (Format Rev) (:assume ..bits/64))

(def: #export frac
  (Format Frac)
  (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)
     (let [mask (..mask <size>)]
       {#reader (do parser.Monad<Parser>
                  [size (:coerce (Reader Nat)
                                 ## TODO: Remove coercion.
                                 (get@ #reader <bits>))]
                  (function (_ [offset binary])
                    (do error.Monad<Error>
                      [#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))]
                    [(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> <binary>]
  [(def: #export <name>
     (Format Text)
     (let [(^open "binary/.") <binary>]
       {#reader (do parser.Monad<Parser>
                  [utf8 binary/reader]
                  (parser.lift (encoding.from-utf8 utf8)))
        #writer (|>> encoding.to-utf8 binary/writer)}))]

  [utf8/8  ..binary/8]
  [utf8/16 ..binary/16]
  [utf8/32 ..binary/32]
  [utf8/64 ..binary/64]
  )

(def: #export text ..utf8/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 maybe
  (All [a] (-> (Format a) (Format (Maybe a))))
  (..or ..any))

(def: #export (list value)
  (All [a] (-> (Format a) (Format (List a))))
  (..rec
   (function (_ recur)
     (..or ..any
           (..and value recur)))))

(def: #export name
  (Format Name)
  (..and ..text ..text))

(def: #export type
  (Format Type)
  (..rec
   (function (_ type)
     (let [pair (..and type type)
           indexed ..nat
           quantified (..and (..list type) type)]
       ($_ ..or
           ## #Primitive
           (..and ..text (..list type))
           ## #Sum
           pair
           ## #Product
           pair
           ## #Function
           pair
           ## #Parameter
           indexed
           ## #Var
           indexed
           ## #Ex
           indexed
           ## #UnivQ
           quantified
           ## #ExQ
           quantified
           ## #Apply
           pair
           ## #Named
           (..and ..name type)
           )))))

(def: #export cursor
  (Format Cursor)
  ($_ ..and ..text ..nat ..nat))

(def: #export code
  (Format Code)
  (..rec
   (function (_ code)
     (let [sequence (..list code)
           code' ($_ ..or
                     ## #Bit
                     ..bit
                     ## #Nat
                     ..nat
                     ## #Int
                     ..int
                     ## #Rev
                     ..rev
                     ## #Frac
                     ..frac
                     ## #Text
                     ..text
                     ## #Identifier
                     ..name
                     ## #Tag
                     ..name
                     ## #Form
                     sequence
                     ## #Tuple
                     sequence
                     ## #Record
                     (..list (..and code code)))]
       (..and ..cursor code')))))