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

(.module:
  [lux (#- nat int rev list type)
   [control
    [monad (#+ do Monad)]
    ["p" parser]
    ["ex" exception (#+ exception:)]
    [equivalence (#+ Equivalence)]]
   [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-tag {range Nat} {byte Nat})
  (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)

(type: #export Read
  (p.Parser [Offset Blob]))

(type: #export (Write a)
  (-> a [Size (-> Offset Blob Blob)]))

(type: #export (Binary a)
  {#read (Read a)
   #write (Write a)})

## Operators
(def: #export (read format input)
  (All [a] (-> (Binary 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] (-> (Binary a) a Blob))
  (let [[valueS valueT] ((get@ #write format) value)]
    (|> valueS blob.create (valueT +0))))

## Primitives
(do-template [<name> <size> <read> <write>]
  [(def: <name>
     (Binary (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)
                  (|> blob
                      (<write> offset value)
                      error.assume))])})]

  [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]
  )

## Combinators
(def: #export (alt leftB rightB)
  (All [l r] (-> (Binary l) (Binary r) (Binary (| 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 blob)
                   (|> blob
                       (blob.write/8 offset +0)
                       error.assume
                       (leftT (.inc offset))))])
              
              (#.Right rightV)
              (let [[rightS rightT] ((get@ #write rightB) rightV)]
                [(.inc rightS)
                 (function (_ offset blob)
                   (|> blob
                       (blob.write/8 offset +1)
                       error.assume
                       (rightT (.inc offset))))])
              ))})

(def: #export (seq preB postB)
  (All [a b] (-> (Binary a) (Binary b) (Binary [a b])))
  {#read (p.seq (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))))]))})

(def: #export (rec body)
  (All [a] (-> (-> (Binary a) (Binary a)) (Binary 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
(def: #export (ignore default)
  (All [a] (-> a (Binary a)))
  {#read (function (_ input)
           (#error.Success [input default]))
   #write (function (_ value)
            [+0
             (function (_ offset blob)
               blob)])})

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

(def: #export bit
  (Binary Bit)
  {#read (function (_ [offset blob])
           (case (blob.read/8 offset blob)
             (#error.Success data)
             (case (: Nat data)
               (^template [<nat> <bit>]
                 <nat> (#error.Success [(inc offset) blob] <bit>))
               ([+0 #0]
                [+1 #1])
               
               _
               (ex.throw invalid-tag [+2 data]))
             
             (#error.Error error)
             (#error.Error error)))
   #write (function (_ value)
            [+1
             (function (_ offset blob)
               (|> blob
                   (blob.write/8 offset (if value +1 +0))
                   error.assume))])})

(def: #export nat (Binary Nat) (:assume ..bits/64))
(def: #export int (Binary Int) (:assume ..bits/64))
(def: #export rev (Binary Rev) (:assume ..bits/64))

(def: #export frac
  (Binary 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
  (Binary 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
  (Binary Text)
  (let [(^slots [#read #write]) ..blob]
    {#read (do p.Monad<Parser>
             [utf8 read]
             (p.lift (encoding.from-utf8 utf8)))
     #write (|>> encoding.to-utf8 write)}))

(def: #export maybe
  (All [a] (-> (Binary a) (Binary (Maybe a))))
  (..alt ..any))

(def: #export (list value)
  (All [a] (-> (Binary a) (Binary (List a))))
  (..rec
   (function (_ recur)
     (..alt ..any
            (..seq value recur)))))

(def: #export ident
  (Binary Ident)
  (..seq ..text ..text))

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

(def: #export cursor
  (Binary Cursor)
  ($_ ..seq ..text ..nat ..nat))

(def: #export code
  (Binary Code)
  (..rec
   (function (_ code)
     (let [sequence (..list code)
           code' ($_ ..alt
                     ## #Bit
                     ..bit
                     ## #Nat
                     ..nat
                     ## #Int
                     ..int
                     ## #Rev
                     ..rev
                     ## #Frac
                     ..frac
                     ## #Text
                     ..text
                     ## #Symbol
                     ..ident
                     ## #Tag
                     ..ident
                     ## #Form
                     sequence
                     ## #Tuple
                     sequence
                     ## #Record
                     (..list (..seq code code)))]
       (..seq ..cursor code')))))