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] <- 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 abstract member FromSequence : seq -> obj type ISequenceProcessor = abstract member ToSequence : obj -> seq abstract member FromSequence : seq -> 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) = 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) = 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) = 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) = 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> then let dP = typedefof> .MakeGenericType(a) |> System.Activator.CreateInstance |> unbox : IDictionaryProcessor Some (dict dP dD a.[0] a.[1]) elif d = typedefof> then let dP = typedefof> .MakeGenericType(a) |> System.Activator.CreateInstance |> unbox : IDictionaryProcessor Some (dict dP dD a.[0] a.[1]) elif d = typedefof> then let sP = typedefof> .MakeGenericType(a) |> System.Activator.CreateInstance |> unbox : ISequenceProcessor Some (seq sP dD a.[0]) elif d = typedefof> then let sP = typedefof> .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 [] 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 [] 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()