RecordUnionSerializers.fs

open System.IO

type Format<'T> =
    {
        Read : BinaryReader -> 'T
        Write : BinaryWriter -> 'T -> unit
    }

(* Unions *)

type UnionPart<'X,'U> =
    {
        R : list<BinaryReader -> 'U>
        W : 'X -> 'U -> BinaryWriter -> unit
    }

let UnionCase (ctor: 'C -> 'U) (fmt: Format<'C>)
    (part: UnionPart<'X,'U>) : UnionPart<('C -> unit) -> 'X,'U> =
    let tag = char part.R.Length
    let write (w: BinaryWriter) x =
        w.Write(tag)
        fmt.Write w x
    {
        R = (fmt.Read >> ctor) :: part.R
        W = fun f u w -> part.W (f (write w)) u w
    }

let private unionEnd<'U> : UnionPart<('U -> unit),'U> =
    {
        R = []
        W = fun f u w -> f u
    }

let Union proof f =
    let part = f unionEnd
    let rs = Array.rev (List.toArray part.R)
    {
        Read = fun r ->
            let tag = int (r.ReadChar())
            rs.[tag] r
        Write = fun w x -> part.W proof x w
    }

(* Records *)

type RecordPart<'X,'R> =
    {
        R : 'X -> BinaryReader -> 'R
        W : list<BinaryWriter -> 'R -> unit>
    }

let RecordField<'F,'U,'X> (proj: 'U -> 'F) (fmt: Format<'F>) (part: RecordPart<'X,'U>) : RecordPart<'F -> 'X, 'U> =
    {
        R = fun x r -> part.R (x (fmt.Read(r))) r
        W = (fun w x -> fmt.Write w (proj x)) :: part.W
    }

let private recordEnd<'T> : RecordPart<'T,'T> =
    {
        R = fun r _ -> r
        W = []
    }

let Record proof f =
    let x = f recordEnd
    let ws = List.toArray x.W
    {
        Read = x.R proof
        Write = fun w x -> for f in ws do f w x
    }

(* Scalars *)

let IntFormat : Format<int> =
    {
        Read = fun r -> r.ReadInt32()
        Write = fun w x -> w.Write(x)
    }

let FloatFormat : Format<float> =
    {
        Read = fun r -> r.ReadDouble()
        Write = fun w x -> w.Write(x)
    }

let StringFormat : Format<string> =
    {
        Read = fun r -> r.ReadString()
        Write = fun w x -> w.Write(x)
    }