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

(.module:
  [lux (#- and or nat int rev list type)
   [type (#+ :share)]
   [abstract
    [monoid (#+ Monoid)]
    ["." fold]
    [monad (#+ Monad do)]
    [equivalence (#+ Equivalence)]]
   [control
    ["." try (#+ Try)]
    ["<>" parser ("#@." monad)
     ["/" binary (#+ Offset Size Parser)]]
    ["." function]
    ["ex" exception (#+ exception:)]]
   [data
    ["." product]
    ["." binary (#+ Binary)]
    [number
     ["." i64]
     ["." frac]]
    [text
     ["." encoding]
     ["%" format]]
    [collection
     ["." list]
     ["." row (#+ Row) ("#@." functor)]]]])

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

(type: #export Mutation
  (-> [Offset Binary] [Offset Binary]))

(type: #export Specification
  [Size Mutation])

(def: #export no-op
  Specification
  [0 function.identity])

(def: #export (instance [size mutation])
  (-> Specification Binary)
  (|> size binary.create [0] mutation product.right))

(structure: #export monoid (Monoid Specification)
  
  (def: identity
    ..no-op)
  
  (def: (compose [sizeL mutL] [sizeR mutR])
    [(n/+ sizeL sizeR)
     (|>> mutL mutR)]))

(type: #export (Writer a)
  (-> a Specification))

(def: #export (run writer value)
  (All [a] (-> (Writer a) a Binary))
  (instance (writer value)))

(template [<name> <size> <write>]
  [(def: #export <name>
     (Writer (I64 Any))
     (function (_ value)
       [<size>
        (function (_ [offset binary])
          [(n/+ <size> offset)
           (|> binary
               (<write> offset value)
               try.assume)])]))]

  [bits/8  /.size/8  binary.write/8]
  [bits/16 /.size/16 binary.write/16]
  [bits/32 /.size/32 binary.write/32]
  [bits/64 /.size/64 binary.write/64]
  )

(def: #export (or left right)
  (All [l r] (-> (Writer l) (Writer r) (Writer (| l r))))
  (function (_ altV)
    (case altV
      (#.Left leftV)
      (let [[leftS leftT] (left leftV)]
        [(.inc leftS)
         (function (_ [offset binary])
           (|> binary
               (binary.write/8 offset 0)
               try.assume
               [(.inc offset)]
               leftT))])
      
      (#.Right rightV)
      (let [[rightS rightT] (right rightV)]
        [(.inc rightS)
         (function (_ [offset binary])
           (|> binary
               (binary.write/8 offset 1)
               try.assume
               [(.inc offset)]
               rightT))])
      )))

(def: #export (and pre post)
  (All [a b] (-> (Writer a) (Writer b) (Writer [a b])))
  (function (_ [preV postV])
    (:: ..monoid compose (pre preV) (post postV))))

(def: #export (rec body)
  (All [a] (-> (-> (Writer a) (Writer a)) (Writer a)))
  (function (_ value)
    (let [writer (body (rec body))]
      (writer value))))

(def: #export any
  (Writer Any)
  (function.constant ..no-op))

(def: #export bit
  (Writer Bit)
  (function (_ value)
    [1
     (function (_ [offset binary])
       [(n/+ 1 offset)
        (|> binary
            (binary.write/8 offset (if value 1 0))
            try.assume)])]))

(template [<name> <type>]
  [(def: #export <name> (Writer <type>) ..bits/64)]

  [nat Nat]
  [int Int]
  [rev Rev]
  )

(def: #export frac
  (Writer Frac)
  (|>> frac.to-bits ..bits/64))

(template [<name> <bits> <size> <write>]
  [(def: #export <name>
     (Writer Binary)
     (let [mask (..mask <size>)]
       (function (_ value)
         (let [size (|> value binary.size (i64.and mask))
               size' (n/+ <size> size)]
           [size'
            (function (_ [offset binary])
              [(n/+ size' offset)
               (try.assume
                (do try.monad
                  [_ (<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]
  )

(template [<name> <binary>]
  [(def: #export <name>
     (Writer Text)
     (|>> encoding.to-utf8 <binary>))]

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

(def: #export text ..utf8/64)

(template [<name> <size> <write>]
  [(def: #export (<name> valueW)
     (All [v] (-> (Writer v) (Writer (Row v))))
     (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 "specification@.") ..monoid
             [size mutation] (|> value
                                 (row@map valueW)
                                 (:: row.fold fold
                                     (function (_ post pre)
                                       (specification@compose pre post))
                                     specification@identity))]
         [(n/+ <size> size)
          (function (_ [offset binary])
            (try.assume
             (do try.monad
               [_ (<write> offset capped-count binary)]
               (wrap (mutation [(n/+ <size> offset) binary])))))])))]

  [row/8  /.size/8  binary.write/8]
  [row/16 /.size/16 binary.write/16]
  [row/32 /.size/32 binary.write/32]
  [row/64 /.size/64 binary.write/64]
  )

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

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

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

(def: #export type
  (Writer 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
  (Writer Cursor)
  ($_ ..and ..text ..nat ..nat))

(def: #export code
  (Writer 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')))))