Binary encoder/decoder for F# types.

Binary.fs

module Serialization.Binary

exception EncodingError

exception NoEncoding of System.Type with
    override this.ToString() =
        sprintf "Failed to derive a binary encoding for type: %O" this.Data0

type E = (string -> int) -> System.IO.BinaryWriter -> obj -> unit
type D = (int -> string) -> System.IO.BinaryReader -> obj
type S = D * E

type Dictionary<'T1,'T2> = System.Collections.Generic.Dictionary<'T1,'T2>

let inline Basic<'T> (rd: System.IO.BinaryReader -> 'T) 
                     (wr: System.IO.BinaryWriter -> 'T -> unit) : S =
    let dec dS r = rd r :> obj
    let enc eS w (x: obj) = wr w (x :?> 'T)
    (dec, enc)

let inline Add<'T> (rd: System.IO.BinaryReader -> 'T)
                   (wr: System.IO.BinaryWriter -> 'T -> unit)
                   (d: Dictionary<_,_>) =
    d.[typeof<'T>] <- Basic rd wr

let Serializers =
    let d = Dictionary()
    Add (fun r -> r.ReadChar()) (fun w -> w.Write) d
    Add (fun r -> r.ReadByte()) (fun w -> w.Write) d
    Add (fun r -> r.ReadSByte()) (fun w -> w.Write) d
    Add (fun r -> r.ReadInt16()) (fun w -> w.Write) d
    Add (fun r -> r.ReadInt32()) (fun w -> w.Write) d
    Add (fun r -> r.ReadInt64()) (fun w -> w.Write) d
    Add (fun r -> r.ReadUInt16()) (fun w -> w.Write) d
    Add (fun r -> r.ReadUInt32()) (fun w -> w.Write) d
    Add (fun r -> r.ReadUInt64()) (fun w -> w.Write) d
    Add (fun r -> r.ReadSingle()) (fun w -> w.Write) d
    Add (fun r -> r.ReadDouble()) (fun w -> w.Write) d
    Add (fun r -> r.ReadDecimal()) (fun w -> w.Write) d
    Add (fun r -> r.ReadBoolean()) (fun w -> w.Write) d
    d.[typeof<string>] <-
        let decString : D = fun dS r -> dS (r.ReadInt32()) :> obj
        let encString : E = fun eS w x -> w.Write (eS (string x))
        (decString, encString)
    d

type FST = Reflection.FSharpType
type FSV = Reflection.FSharpValue

let TupleEncoder dE (t: System.Type) : E =
    let e = Array.map dE (FST.GetTupleElements t)
    let r = FSV.PreComputeTupleReader t
    fun eS w o -> Array.iter2 (fun e x -> e eS w x) e (r o)

let TupleDecoder dD (t: System.Type) : D =
    let e = Array.map dD (FST.GetTupleElements t)
    let c = FSV.PreComputeTupleConstructor t
    fun dS r -> c (Array.map (fun e -> e dS r) e)

let ArrayEncoder (dE: System.Type -> E) (t: System.Type) : E =
    let e = dE (t.GetElementType())
    fun eS w o ->
        let o = o :?> System.Array
        w.Write o.Length
        for x in o do
            e eS w x

let ArrayDecoder (dD: System.Type -> D) (t: System.Type) : D =
    let eT = t.GetElementType()
    let e  = dD eT
    fun dS r ->
        let k = r.ReadInt32()
        let res = System.Array.CreateInstance(eT, k)
        for i in 0 .. k - 1 do
            res.SetValue(e dS r, i)
        res :> obj

let Flags =
    System.Reflection.BindingFlags.Public
    ||| System.Reflection.BindingFlags.NonPublic

let UnionEncoder dE (t: System.Type) : E =
    let tR = FSV.PreComputeUnionTagReader(t, Flags)
    let cs =
        FST.GetUnionCases(t, Flags)
        |> Array.map (fun c ->
            let r = FSV.PreComputeUnionReader(c, Flags)
            let fs =
                c.GetFields()
                |> Array.map (fun f -> dE f.PropertyType)
            (r, fs))
    fun wS w o ->
        let tag = tR o
        w.Write (byte tag)
        let (r, fs) = cs.[tag]
        Array.iter2 (fun e x -> e wS w x) fs (r o)

let UnionDecoder dD (t: System.Type) : D =
    let cs =
        FST.GetUnionCases(t, Flags)
        |> Array.map (fun c ->
            let mk = FSV.PreComputeUnionConstructor(c, Flags)
            let fs =
                c.GetFields()
                |> Array.map (fun f -> dD f.PropertyType)
            (mk, fs))
    let k = cs.Length
    fun dS r ->
        let tag = int (r.ReadByte())
        let (mk, fs) = cs.[tag]
        fs
        |> Array.map (fun f -> f dS r)
        |> mk

let RecordEncoder dE (t: System.Type) : E =
    let fs =
        FST.GetRecordFields(t, Flags)
        |> Array.map (fun f ->
            let r = FSV.PreComputeRecordFieldReader f
            (fun eS w o -> dE f.PropertyType eS w (r o)))
    fun eS w o -> Array.iter (fun f -> f eS w o) fs

let RecordDecoder dD (t: System.Type) : D =
    let mk = FSV.PreComputeRecordConstructor(t, Flags)
    let fs =
        FST.GetRecordFields(t, Flags)
        |> Array.map (fun f -> dD f.PropertyType)
    fun dS r ->
        fs
        |> Array.map (fun dec -> dec dS r)
        |> mk

type IDictionaryProcessor =
    abstract member ToSequence : obj -> seq<obj*obj>
    abstract member FromSequence : seq<obj*obj> -> obj

type ISequenceProcessor =
    abstract member ToSequence : obj -> seq<obj>
    abstract member FromSequence : seq<obj> -> obj

type DictionaryProcessor<'T1,'T2 when 'T1 : comparison>() =
    interface IDictionaryProcessor with
        member this.ToSequence (map: obj) =
            (map :?> Dictionary<'T1,'T2>)
            |> Seq.map (fun (KeyValue (k, v)) -> (box k, box v))
        member this.FromSequence (seq: seq<obj*obj>) =
            let d = Dictionary()
            for (k, v) in seq do
                d.[k :?> 'T1] <- v :?> 'T2
            box d

type MapProcessor<'T1,'T2 when 'T1 : comparison>() =
    interface IDictionaryProcessor with
        member this.ToSequence (map: obj) =
            (map :?> Map<'T1,'T2>)
            |> Seq.map (fun (KeyValue (k, v)) -> (box k, box v))
        member this.FromSequence (seq: seq<obj*obj>) =
            seq
            |> Seq.map (fun (k, v) -> (k :?> 'T1, v :?> 'T2))
            |> Map.ofSeq
            |> box

type ListProcessor<'T>() =
    interface ISequenceProcessor with
        member this.ToSequence (x: obj) = Seq.map box (x :?> list<'T>)
        member this.FromSequence (s: seq<obj>) = box [for x in s -> x :?> 'T]

type SetProcessor<'T when 'T : comparison>() =
    interface ISequenceProcessor with
        member this.ToSequence (x: obj) = Seq.map box (x :?> Set<'T>)
        member this.FromSequence (s: seq<obj>) =
            s
            |> Seq.map (fun x -> x :?> 'T)
            |> Set.ofSeq
            |> box

let DictionaryDecoder (dP: IDictionaryProcessor) dD kT vT : D =
    let kD = dD kT
    let vD = dD vT
    fun dS r ->
        let k = r.ReadInt32()
        Array.init k (fun _ ->
            let key = kD dS r
            let value = vD dS r
            (key, value))
        |> dP.FromSequence

let DictionaryEncoder (dP: IDictionaryProcessor) dE kT vT : E =
    let kE = dE kT
    let vE = dE vT
    fun eS w x ->
        let s = dP.ToSequence x
        w.Write (Seq.length s)
        for (k, v) in s do
            kE eS w k
            vE eS w v

let SequenceDecoder (sP: ISequenceProcessor) dD eT : D =
    let eD = dD eT
    fun dS r ->
        let k = r.ReadInt32()
        Array.init k (fun _ -> eD dS r)
        |> sP.FromSequence

let SequenceEncoder (sP: ISequenceProcessor) dE eT : E =
    let eE = dE eT
    fun dS w x ->
        let s = sP.ToSequence x
        w.Write (Seq.length s)
        for e in s do
            eE dS w e

let inline GetEncoding scalar array tuple union record dict seq
                       (cache: Dictionary<_,_>) =
    let recurse t =
        lock cache <| fun () ->
            cache.[t] <-
                Choice1Of2 (fun i v ->
                    match cache.TryGetValue t with
                    | true, Choice1Of2 f -> f i v
                    | _ -> raise (NoEncoding t))
    let rec get (t: System.Type) =
        let derive dD =
            try
                let r =
                    if t.IsGenericType then
                        let d = t.GetGenericTypeDefinition()
                        let a = t.GetGenericArguments()
                        if d = typedefof<Map<_,_>> then
                            let dP =
                                typedefof<MapProcessor<_,_>>
                                    .MakeGenericType(a)
                                |> System.Activator.CreateInstance
                                |> unbox : IDictionaryProcessor
                            Some (dict dP dD a.[0] a.[1])
                        elif d = typedefof<Dictionary<_,_>> then
                            let dP =
                                typedefof<DictionaryProcessor<_,_>>
                                    .MakeGenericType(a)
                                |> System.Activator.CreateInstance
                                |> unbox : IDictionaryProcessor
                            Some (dict dP dD a.[0] a.[1])
                        elif d = typedefof<list<_>> then
                            let sP =
                                typedefof<ListProcessor<_>>
                                    .MakeGenericType(a)
                                |> System.Activator.CreateInstance
                                |> unbox : ISequenceProcessor
                            Some (seq sP dD a.[0])
                        elif d = typedefof<Set<_>> then
                            let sP =
                                typedefof<SetProcessor<_>>
                                    .MakeGenericType(a)
                                |> System.Activator.CreateInstance
                                |> unbox : ISequenceProcessor
                            Some (seq sP dD a.[0])
                        else
                            None
                    else
                        None
                if r.IsSome then (Choice1Of2 r.Value) else
                    if t.IsArray && t.GetArrayRank() = 1 then
                        Choice1Of2 (array dD t)
                    elif FST.IsTuple t then
                        Choice1Of2 (tuple dD t)
                    elif FST.IsUnion (t, Flags) then
                        recurse t
                        Choice1Of2 (union dD t)
                    elif FST.IsRecord (t, Flags) then
                        recurse t
                        Choice1Of2 (record dD t)
                    else
                        Choice2Of2 t
            with NoEncoding t ->
                Choice2Of2 t
        if t = null then Choice2Of2 t else
            match Serializers.TryGetValue t with
            | true, x ->
                Choice1Of2 (scalar x)
            | _ ->
                let d =
                    match cache.TryGetValue t with
                    | true, d -> Some d
                    | _ -> None
                match d with
                | Some d -> d
                | None ->
                    let dD t =
                        match get t with
                        | Choice1Of2 d -> d
                        | Choice2Of2 d -> raise (NoEncoding t)
                    let d = derive dD
                    cache.[t] <- d
                    d
    get

[<Sealed>]
type Encoding(t: System.Type, d: D, e: E) =

    member this.Decode stream =
        let mode = System.IO.Compression.CompressionMode.Decompress
        use reader =
            new System.IO.BinaryReader(
                new System.IO.Compression.GZipStream(stream, mode))
        try
            if reader.ReadString() <> t.AssemblyQualifiedName then
                raise EncodingError
            let dS = Dictionary()
            for i in 0 .. reader.ReadInt32() - 1 do
                let s = reader.ReadString()
                dS.[i] <- s
            d (fun x -> dS.[x]) reader
        with _ ->
            raise EncodingError

    member this.Encode stream (value: obj) =
        let mode   = System.IO.Compression.CompressionMode.Compress
        use memory = new System.IO.MemoryStream()
        use actual = new System.IO.Compression.GZipStream(stream, mode)
        use wM     = new System.IO.BinaryWriter(memory)
        use wA     = new System.IO.BinaryWriter(actual)
        try
            let eS = Dictionary()
            let encS x =
                match eS.TryGetValue x with
                | true, y -> y
                | _ ->
                    let y = eS.Count
                    eS.[x] <- y
                    y
            e encS wM value
            wA.Write t.AssemblyQualifiedName
            wA.Write eS.Count
            for v in eS.Keys do
                wA.Write v
            memory.WriteTo actual
        with _ ->
            raise EncodingError

    member this.Type = t

[<Sealed>]
type EncodingProvider() =

    let Decoders = Dictionary()
    let Encoders = Dictionary()

    let GetDecoder (t: System.Type) =
        GetEncoding fst ArrayDecoder TupleDecoder
            UnionDecoder RecordDecoder
            DictionaryDecoder SequenceDecoder
            Decoders t

    let GetEncoder (t: System.Type) =
        GetEncoding snd ArrayEncoder TupleEncoder
            UnionEncoder RecordEncoder
            DictionaryEncoder SequenceEncoder
            Encoders t

    member this.DeriveEncoding t =
        match GetEncoder t, GetDecoder t with
        | Choice1Of2 e, Choice1Of2 d ->
            Encoding (t, d, e)
        | Choice2Of2 t, _ | _, Choice2Of2 t ->
            raise (NoEncoding t)

    static member Create() =
        EncodingProvider()

Binary.fsi

/// Implements binary serialization for server-side use.
/// The encoding supports all records, unions, numeric types,
/// strings, rank-1 arrays, maps, sets, lists and dictionaries.
/// Strings are interned for efficiency. The encoding also uses
/// binary compression.
module Serialization.Binary

/// Thrown when the decoder fails to reconstruct a value.
exception EncodingError

/// Thrown when no decoder can be derived for a given type.
exception NoEncoding of System.Type

/// Represents an encoding for a given type.
[<Sealed>]
type Encoding =

    /// Decodes an object from a stream.
    member Decode : System.IO.Stream -> obj

    /// Encodes an object to a stream.
    member Encode : System.IO.Stream -> obj -> unit

    /// The type for which operations are supported.
    member Type : System.Type

/// Constructs Encoding objects.
[<Sealed>]
type EncodingProvider =

    /// Derives an encoding for a given type.
    member DeriveEncoding : System.Type -> Encoding

    /// Constructs a new EncodingProvider.
    static member Create : unit -> EncodingProvider