diff --git a/FSharp.MongoDB.Driver.Tests/AcceptanceTests.fs b/FSharp.MongoDB.Driver.Tests/AcceptanceTests.fs index 6a02ce0..a3f1e60 100644 --- a/FSharp.MongoDB.Driver.Tests/AcceptanceTests.fs +++ b/FSharp.MongoDB.Driver.Tests/AcceptanceTests.fs @@ -1,11 +1,10 @@ -module ``Acceptance Tests`` +module FSharp.MongoDB.Driver.Tests open System open FsUnit open NUnit.Framework open MongoDB.Bson open MongoDB.Driver -open FSharp.MongoDB.Driver open System.Linq open TestUtils open MongoDB.Bson.Serialization.Attributes @@ -45,6 +44,7 @@ type RecordWithCollections = IntVal: int DoubleVal: double ListVal: int list + IntValOpt: int ValueOption SetVal: Set option MapVal: Map option OptionVal: int option } @@ -74,7 +74,7 @@ let init() = client <- new MongoClient(connectionString) client.DropDatabase(dbname) db <- client.GetDatabase(dbname) - Serializers.Register() + Register() [] let teardown() = @@ -256,6 +256,7 @@ let ``It can serialize record with list`` () = IntVal = 123 DoubleVal = 1.23 ListVal = [1; 2; 3] + IntValOpt = ValueSome 42 SetVal = ["toto"; "titi"; "tata"] |> Set |> Some MapVal = ["toto", 42; "titi", 666] |> Map |> Some OptionVal = Some 123 } diff --git a/FSharp.MongoDB.Driver/Serializers.fs b/FSharp.MongoDB.Driver/Serializers.fs index 25acd06..63b4baf 100644 --- a/FSharp.MongoDB.Driver/Serializers.fs +++ b/FSharp.MongoDB.Driver/Serializers.fs @@ -1,4 +1,4 @@ -namespace FSharp.MongoDB.Driver +module FSharp.MongoDB.Driver open System open Microsoft.FSharp.Reflection @@ -7,154 +7,171 @@ open MongoDB.Bson.IO open MongoDB.Bson.Serialization open MongoDB.Bson.Serialization.Serializers -module Serializers = - - type OptionSerializer<'T>() = - inherit SerializerBase>() - - override _.Serialize(context, _, value) = - match value with - | None -> - context.Writer.WriteNull() - | _ -> - let contentSerializer = BsonSerializer.LookupSerializer(typeof<'T>) - contentSerializer.Serialize(context, value.Value) - - override _.Deserialize(context, args) = - match context.Reader.CurrentBsonType with - | BsonType.Null -> - context.Reader.ReadNull() - None - | _ -> - let contentSerializer = BsonSerializer.LookupSerializer(typeof<'T>) - let obj = contentSerializer.Deserialize(context, args) :?> 'T - Some obj - - - type MapSerializer<'K, 'V when 'K : comparison>() = - inherit SerializerBase>() - - let contentSerializer = BsonSerializer.LookupSerializer(typeof>) - - override _.Serialize(context, _, value) = - let dict = value |> Map.toSeq |> dict - contentSerializer.Serialize(context, dict) - - override _.Deserialize(context, args) = - let dict = contentSerializer.Deserialize(context, args) :?> System.Collections.Generic.IDictionary<'K, 'V> - dict |> Seq.map (|KeyValue|) |> Map.ofSeq - - - type ListSerializer<'T>() = - inherit SerializerBase>() - - let contentSerializer = BsonSerializer.LookupSerializer(typeof<'T[]>) - - override _.Serialize(context, _, value) = - let list = value |> List.toArray - contentSerializer.Serialize(context, list) - - override _.Deserialize(context, args) = - let list = contentSerializer.Deserialize(context, args) :?>'T[] - list |> List.ofArray - - - let fsharpType (typ : Type) = - typ.GetCustomAttributes(typeof, true) - |> Seq.cast - |> Seq.map(fun t -> t.SourceConstructFlags) - |> Seq.tryHead - - - type UnionCaseSerializer<'T>() = - inherit SerializerBase<'T>() - - let readItems context args (types : Type seq) = - types - |> Seq.fold(fun state t -> - let serializer = BsonSerializer.LookupSerializer(t) - let item = serializer.Deserialize(context, args) - item :: state) [] - |> Seq.toArray |> Array.rev - - override _.Serialize(context, args, value) = - let writer = context.Writer - writer.WriteStartDocument() - let info, values = FSharpValue.GetUnionFields(value, args.NominalType) - writer.WriteName(info.Name) - writer.WriteStartArray() - values - |> Seq.zip(info.GetFields()) - |> Seq.iter (fun (field, value) -> - let itemSerializer = BsonSerializer.LookupSerializer(field.PropertyType) - itemSerializer.Serialize(context, args, value)) - writer.WriteEndArray() - writer.WriteEndDocument() - - override _.Deserialize(context, args) = - let reader = context.Reader - reader.ReadStartDocument() - let typeName = reader.ReadName() - let unionType = - FSharpType.GetUnionCases(args.NominalType) - |> Seq.where (fun case -> case.Name = typeName) - |> Seq.head - reader.ReadStartArray() - let items = readItems context args (unionType.GetFields() |> Seq.map(fun f -> f.PropertyType)) - reader.ReadEndArray() - reader.ReadEndDocument() - FSharpValue.MakeUnion(unionType, items) :?> 'T - - - let private getGenericArgumentOf baseType (typ: Type) = - if typ.IsGenericType && typ.GetGenericTypeDefinition() = baseType - then Some <| typ.GetGenericArguments() - else None - - let inline private createInstance<'T> typ = Activator.CreateInstance(typ) :?> 'T - let inline private makeGenericType<'T> typ = typedefof<'T>.MakeGenericType typ - - let specificSerializer<'nominal,'serializer> = - getGenericArgumentOf typedefof<'nominal> >> Option.map (makeGenericType<'serializer> >> createInstance) - let listSerializer typ = typ |> specificSerializer, ListSerializer<_>> - let mapSerializer typ = typ |> specificSerializer, MapSerializer<_, _>> - let optionSerializer typ = typ |> specificSerializer, OptionSerializer<_>> - - let unionCaseSerializer typ = - let gen = makeGenericType> >> createInstance - gen [| typ |] |> Some - - type FsharpSerializationProvider(useOptionNull) = - let serializers = - [ if useOptionNull then SourceConstructFlags.SumType, optionSerializer - SourceConstructFlags.ObjectType, mapSerializer - SourceConstructFlags.SumType, listSerializer - SourceConstructFlags.SumType, unionCaseSerializer ] - - interface IBsonSerializationProvider with - member _.GetSerializer(typ : Type) = - match fsharpType typ with - | Some flag -> - serializers - |> List.filter (fst >> (=) flag) - |> List.map snd - |> List.fold (fun result s -> result |> Option.orElseWith (fun _ -> s typ)) None - | _ -> None - |> Option.toObj - - let mutable isRegistered = false - - type RegistrationOption = { UseOptionNull: bool } - let defaultRegistrationOption = { UseOptionNull = true } - - // Registers all F# serializers - let RegisterWithOptions(opt) = + +type OptionSerializer<'T>() = + inherit SerializerBase>() + + override _.Serialize(context, _, value) = + match value with + | None -> + context.Writer.WriteNull() + | _ -> + let contentSerializer = BsonSerializer.LookupSerializer(typeof<'T>) + contentSerializer.Serialize(context, value.Value) + + override _.Deserialize(context, args) = + match context.Reader.CurrentBsonType with + | BsonType.Null -> + context.Reader.ReadNull() + None + | _ -> + let contentSerializer = BsonSerializer.LookupSerializer(typeof<'T>) + let obj = contentSerializer.Deserialize(context, args) :?> 'T + Some obj + + +type ValueOptionSerializer<'T>() = + inherit SerializerBase>() + + override _.Serialize(context, _, value) = + match value with + | ValueNone -> + context.Writer.WriteNull() + | _ -> + let contentSerializer = BsonSerializer.LookupSerializer(typeof<'T>) + contentSerializer.Serialize(context, value.Value) + + override _.Deserialize(context, args) = + match context.Reader.CurrentBsonType with + | BsonType.Null -> + context.Reader.ReadNull() + ValueNone + | _ -> + let contentSerializer = BsonSerializer.LookupSerializer(typeof<'T>) + let obj = contentSerializer.Deserialize(context, args) :?> 'T + ValueSome obj + + +type MapSerializer<'K, 'V when 'K : comparison>() = + inherit SerializerBase>() + + let contentSerializer = BsonSerializer.LookupSerializer(typeof>) + + override _.Serialize(context, _, value) = + let dict = value |> Map.toSeq |> dict + contentSerializer.Serialize(context, dict) + + override _.Deserialize(context, args) = + let dict = contentSerializer.Deserialize(context, args) :?> System.Collections.Generic.IDictionary<'K, 'V> + dict |> Seq.map (|KeyValue|) |> Map.ofSeq + + +type ListSerializer<'T>() = + inherit SerializerBase>() + + let contentSerializer = BsonSerializer.LookupSerializer(typeof<'T[]>) + + override _.Serialize(context, _, value) = + let list = value |> List.toArray + contentSerializer.Serialize(context, list) + + override _.Deserialize(context, args) = + let list = contentSerializer.Deserialize(context, args) :?>'T[] + list |> List.ofArray + + +let fsharpType (typ : Type) = + typ.GetCustomAttributes(typeof, true) + |> Seq.cast + |> Seq.map(fun t -> t.SourceConstructFlags) + |> Seq.tryHead + + +type UnionCaseSerializer<'T>() = + inherit SerializerBase<'T>() + + let readItems context args (types : Type seq) = + types + |> Seq.fold(fun state t -> + let serializer = BsonSerializer.LookupSerializer(t) + let item = serializer.Deserialize(context, args) + item :: state) [] + |> Seq.toArray |> Array.rev + + override _.Serialize(context, args, value) = + let writer = context.Writer + writer.WriteStartDocument() + let info, values = FSharpValue.GetUnionFields(value, args.NominalType) + writer.WriteName(info.Name) + writer.WriteStartArray() + values + |> Seq.zip(info.GetFields()) + |> Seq.iter (fun (field, value) -> + let itemSerializer = BsonSerializer.LookupSerializer(field.PropertyType) + itemSerializer.Serialize(context, args, value)) + writer.WriteEndArray() + writer.WriteEndDocument() + + override _.Deserialize(context, args) = + let reader = context.Reader + reader.ReadStartDocument() + let typeName = reader.ReadName() + let unionType = + FSharpType.GetUnionCases(args.NominalType) + |> Seq.where (fun case -> case.Name = typeName) + |> Seq.head + reader.ReadStartArray() + let items = readItems context args (unionType.GetFields() |> Seq.map(fun f -> f.PropertyType)) + reader.ReadEndArray() + reader.ReadEndDocument() + FSharpValue.MakeUnion(unionType, items) :?> 'T + + +let private getGenericArgumentOf baseType (typ: Type) = + if typ.IsGenericType && typ.GetGenericTypeDefinition() = baseType + then Some <| typ.GetGenericArguments() + else None + +let inline private createInstance<'T> typ = Activator.CreateInstance(typ) :?> 'T +let inline private makeGenericType<'T> typ = typedefof<'T>.MakeGenericType typ + +let specificSerializer<'nominal,'serializer> = + getGenericArgumentOf typedefof<'nominal> >> Option.map (makeGenericType<'serializer> >> createInstance) +let listSerializer typ = typ |> specificSerializer, ListSerializer<_>> +let mapSerializer typ = typ |> specificSerializer, MapSerializer<_, _>> +let optionSerializer typ = typ |> specificSerializer, OptionSerializer<_>> +let valueOptionSerializer typ = typ |> specificSerializer, ValueOptionSerializer<_>> + +let unionCaseSerializer typ = + let gen = makeGenericType> >> createInstance + gen [| typ |] |> Some + + + +type FSharpSerializationProvider() = + let serializers = + [ SourceConstructFlags.SumType, optionSerializer + SourceConstructFlags.SumType, valueOptionSerializer + SourceConstructFlags.ObjectType, mapSerializer + SourceConstructFlags.SumType, listSerializer + SourceConstructFlags.SumType, unionCaseSerializer ] + + static let mutable isRegistered = false + static member Register() = if not isRegistered then - BsonSerializer.RegisterSerializationProvider(FsharpSerializationProvider(opt.UseOptionNull)) + BsonSerializer.RegisterSerializationProvider(FSharpSerializationProvider()) isRegistered <- true + interface IBsonSerializationProvider with + member _.GetSerializer(typ : Type) = + match fsharpType typ with + | Some flag -> + serializers + |> List.filter (fst >> (=) flag) + |> List.map snd + |> List.fold (fun result s -> result |> Option.orElseWith (fun _ -> s typ)) None + | _ -> None + |> Option.toObj -type Serializers() = - static member Register(?opts: Serializers.RegistrationOption) = - Serializers.RegisterWithOptions(opts |> Option.defaultValue Serializers.defaultRegistrationOption) +let Register = FSharpSerializationProvider.Register diff --git a/README.md b/README.md index c15fa79..1526059 100644 --- a/README.md +++ b/README.md @@ -8,6 +8,7 @@ Following types are supported: * Map * Set * Option +* ValueOption * Discriminated Unions Records are supported as well out of the box with official MongoDB driver. Probably you want to add `CLIMutable` attribute on the record to support automatic ObjectId initialization. @@ -23,12 +24,9 @@ Install this project via NuGet. On startup you have to register `FSharp.MongoDB.Driver`: ```ocaml -open FSharp.MongoDB.Driver -Serializers.Register() +FSharp.MongoDB.Driver.Register() ``` -The `Serializers.Register()` call just registers serializers with the MongoDB driver. - # Usage Use FSharp.MongoDB.Driver like you normally would in C#.