path: root/stdlib/source/library/lux/control/parser/binary.lux

(.module:
  [library
   [lux {"-" and or nat int rev list type}
    [type {"+" :sharing}]
    [abstract
     [hash {"+" Hash}]
     [monad {"+" do}]]
    [control
     ["[0]" try {"+" Try}]
     ["[0]" exception {"+" exception:}]]
    [data
     ["/" binary {"+" Binary}]
     [text
      ["%" format {"+" format}]
      [encoding
       ["[0]" utf8]]]
     [collection
      ["[0]" list]
      ["[0]" row {"+" Row}]
      ["[0]" set {"+" Set}]]]
    [macro
     ["[0]" template]]
    [math
     [number
      ["n" nat]
      ["[0]" frac]]]]]
  ["[0]" // ("[1]#[0]" monad)])

(type: .public Offset
  Nat)

(type: .public Parser
  (//.Parser [Offset Binary]))

(exception: .public (binary_was_not_fully_read [binary_length Nat
                                                bytes_read Nat])
  (exception.report
   ["Binary length" (%.nat binary_length)]
   ["Bytes read" (%.nat bytes_read)]))

(def: .public (result 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.except ..binary_was_not_fully_read [length end])))))

(def: .public end?
  (Parser Bit)
  (function (_ (^@ input [offset data]))
    {try.#Success [input (n.= offset (/.size data))]}))

(def: .public offset
  (Parser Offset)
  (function (_ (^@ input [offset data]))
    {try.#Success [input offset]}))

(def: .public remaining
  (Parser Nat)
  (function (_ (^@ input [offset data]))
    {try.#Success [input (n.- offset (/.size data))]}))

(type: .public Size
  Nat)

(def: .public size/8 Size 1)
(def: .public size/16 Size (n.* 2 size/8))
(def: .public size/32 Size (n.* 2 size/16))
(def: .public size/64 Size (n.* 2 size/32))

(template [<name> <size> <read>]
  [(def: .public <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: .public <name> (Parser <type>) ..bits/64)]

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

(def: .public frac
  (Parser Frac)
  (//#each frac.of_bits ..bits/64))

(exception: .public (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)]
     (with_expansions [<case>+' (template.spliced <case>+)]
       (case flag
         (^template [<number> <tag> <parser>]
           [<number> (`` (# ! each (|>> {(~~ (template.spliced <tag>))}) <parser>))])
         (<case>+')
         
         _ (//.lifted (exception.except ..invalid_tag [(template.amount [<case>+]) flag])))))])

(def: .public (or left right)
  (All (_ l r) (-> (Parser l) (Parser r) (Parser (Or l r))))
  (!variant [[0 [.#Left] left]
             [1 [.#Right] right]]))

(def: .public (rec body)
  (All (_ a) (-> (-> (Parser a) (Parser a)) (Parser a)))
  (function (_ input)
    (let [parser (body (rec body))]
      (parser input))))

(def: .public any
  (Parser Any)
  (//#in []))

(exception: .public (not_a_bit [value Nat])
  (exception.report
   ["Expected values" "either 0 or 1"]
   ["Actual value" (%.nat value)]))

(def: .public bit
  (Parser Bit)
  (do //.monad
    [value (: (Parser Nat)
              ..bits/8)]
    (case value
      0 (in #0)
      1 (in #1)
      _ (//.lifted (exception.except ..not_a_bit [value])))))

(def: .public (segment size)
  (-> Nat (Parser Binary))
  (function (_ [offset binary])
    (case size
      0 {try.#Success [[offset binary] (/.empty 0)]}
      _ (|> binary
            (/.slice offset size)
            (# try.monad each (|>> [[(n.+ size offset) binary]]))))))

(template [<size> <name> <bits>]
  [(`` (def: .public <name>
         (Parser Binary)
         (do //.monad
           [size (//#each .nat <bits>)]
           (..segment size))))]

  [08 binary/8  ..bits/8]
  [16 binary/16 ..bits/16]
  [32 binary/32 ..bits/32]
  [64 binary/64 ..bits/64]
  )

(template [<size> <name> <binary>]
  [(`` (def: .public <name>
         (Parser Text)
         (do //.monad
           [utf8 <binary>]
           (//.lifted (# utf8.codec decoded utf8)))))]

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

(def: .public text ..utf8/64)

(template [<size> <name> <bits>]
  [(def: .public (<name> valueP)
     (All (_ v) (-> (Parser v) (Parser (Row v))))
     (do //.monad
       [amount (: (Parser Nat)
                  <bits>)]
       (loop [index 0
              output (:sharing [v]
                               (Parser v)
                               valueP
                               
                               (Row v)
                               row.empty)]
         (if (n.< amount index)
           (do //.monad
             [value valueP]
             (recur (.++ index)
                    (row.suffix value output)))
           (//#in output)))))]

  [08 row/8  ..bits/8]
  [16 row/16 ..bits/16]
  [32 row/32 ..bits/32]
  [64 row/64 ..bits/64]
  )

(def: .public maybe
  (All (_ a) (-> (Parser a) (Parser (Maybe a))))
  (..or ..any))

(def: .public (list value)
  (All (_ a) (-> (Parser a) (Parser (List a))))
  (..rec
   (|>> (//.and value)
        (..or ..any))))

(exception: .public set_elements_are_not_unique)

(def: .public (set hash value)
  (All (_ a) (-> (Hash a) (Parser a) (Parser (Set a))))
  (do //.monad
    [raw (..list value)
     .let [output (set.of_list hash raw)]
     _ (//.assertion (exception.error ..set_elements_are_not_unique [])
                     (n.= (list.size raw)
                          (set.size output)))]
    (in output)))

(def: .public name
  (Parser Name)
  (//.and ..text ..text))

(def: .public 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: .public location
  (Parser Location)
  ($_ //.and ..text ..nat ..nat))

(def: .public 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 [.#Form] sequence]
                          [8 [.#Variant] sequence]
                          [9 [.#Tuple] sequence]]))))))