Added InferDictionariesFromRecords flag to JSON TP

src/Json/JsonGenerator.fs

@@ -26,21 +26,24 @@ type internal JsonGenerationContext =
     JsonValueType : Type
     JsonRuntimeType : Type
     TypeCache : Dictionary<InferedType, ProvidedTypeDefinition>
+    PreferDictionaries: bool
     GenerateConstructors : bool }
 
-  static member Create(cultureStr, tpType, ?uniqueNiceName, ?typeCache) =
+  static member Create(cultureStr, tpType, ?uniqueNiceName, ?typeCache, ?preferDictionaries) =
     let uniqueNiceName = defaultArg uniqueNiceName (NameUtils.uniqueGenerator NameUtils.nicePascalName)
     let typeCache = defaultArg typeCache (Dictionary())
-    JsonGenerationContext.Create(cultureStr, tpType, uniqueNiceName, typeCache, true)
+    let preferDictionaries = defaultArg preferDictionaries false
+    JsonGenerationContext.Create(cultureStr, tpType, uniqueNiceName, typeCache, preferDictionaries, true)
 
-  static member Create(cultureStr, tpType, uniqueNiceName, typeCache, generateConstructors) =
+  static member Create(cultureStr, tpType, uniqueNiceName, typeCache, preferDictionaries, generateConstructors) =
     { CultureStr = cultureStr
       TypeProviderType = tpType
       UniqueNiceName = uniqueNiceName 
       IJsonDocumentType = typeof<IJsonDocument>
       JsonValueType = typeof<JsonValue>
       JsonRuntimeType = typeof<JsonRuntime>
-      TypeCache = typeCache 
+      TypeCache = typeCache
+      PreferDictionaries = preferDictionaries
       GenerateConstructors = generateConstructors }
   member x.MakeOptionType(typ:Type) = 
     typedefof<option<_>>.MakeGenericType typ
@@ -291,15 +294,98 @@ module JsonTypeBuilder =
         let makeUnique = NameUtils.uniqueGenerator NameUtils.nicePascalName
         makeUnique "JsonValue" |> ignore
 
-        // Add all record fields as properties
-        let members = 
+        let inferedKeyValueType =
+          let aggr = List.fold (StructuralInference.subtypeInfered false) InferedType.Top
+          let dropRecordName infType =
+            match infType with
+            | InferedType.Record (_, fields, opt) -> InferedType.Record (None, fields, opt)
+            | _  -> infType
+
+          if not ctx.PreferDictionaries
+          then None
+          else
+            let infType = 
+              [for prop in props -> StructuralInference.getInferedTypeFromString (TextRuntime.GetCulture ctx.CultureStr) prop.Name None] 
+              |> aggr
+            match infType with
+            | InferedType.Primitive (typ = typ) when typ <> typeof<string> -> 
+              let inferValueType = ([for prop in props -> prop.Type |> dropRecordName] |> aggr).DropOptionality ()
+              (infType, inferValueType) |> Some 
+            | _ -> None
+
+        match inferedKeyValueType with
+        | Some (inferedKeyType, inferedValueType) ->
+          // Add all record fields as dictionary items
+          let valueName = name + "Value"
+
+          let keyResult = generateJsonType ctx (*canPassAllConversionCallingTypes*)false (*optionalityHandledByParent*)true "" inferedKeyType  
+          let valueResult = generateJsonType ctx (*canPassAllConversionCallingTypes*)false (*optionalityHandledByParent*)true valueName inferedValueType  
+          let valueConvertedTypeErased = valueResult.ConvertedTypeErased ctx
+
+          let tupleType = Microsoft.FSharp.Reflection.FSharpType.MakeTupleType([|keyResult.ConvertedType; valueResult.ConvertedType|])
+          let itemsSeqType = typedefof<_ seq>.MakeGenericType([|tupleType|])
+
+          let itemsGetter (Singleton jDoc) = 
+            ctx.JsonRuntimeType?ConvertRecordToDictionary (keyResult.ConvertedType, valueConvertedTypeErased) (jDoc, keyResult.ConverterFunc ctx, valueResult.ConverterFunc ctx)
+
+          let keysGetter (Singleton jDoc) =
+            ctx.JsonRuntimeType?GetKeysFromInferedDictionary (keyResult.ConvertedType) (jDoc, keyResult.ConverterFunc ctx)
+
+          let valuesGetter (Singleton jDoc) =
+            ctx.JsonRuntimeType?GetValuesFromInferedDictionary (valueConvertedTypeErased) (jDoc, valueResult.ConverterFunc ctx)
+
+          let (|Doubleton|) = function [f; s] -> f, s | _ -> failwith "Parameter mismatch"
+
+          let itemGetter (Doubleton (jDoc, key)) =
+            ctx.JsonRuntimeType?GetValueByKeyFromInferedDictionary (keyResult.ConvertedType, valueConvertedTypeErased) (jDoc, keyResult.ConverterFunc ctx, valueResult.ConverterFunc ctx, key)
+
+          let tryFindCode (Doubleton (jDoc, key)) =
+            ctx.JsonRuntimeType?TryGetValueByKeyFromInferedDictionary (keyResult.ConvertedType, valueConvertedTypeErased) (jDoc, keyResult.ConverterFunc ctx, valueResult.ConverterFunc ctx, key)
+
+          let containsKeyCode (Doubleton (jDoc, key)) =
+            ctx.JsonRuntimeType?InferedDictionaryContainsKey (keyResult.ConvertedType) (jDoc, keyResult.ConverterFunc ctx, key)
+
+          let countGetter (Singleton jDoc) =
+            <@@ JsonRuntime.GetRecordProperties(%%jDoc).Length @@>
+
+          let isEmptyGetter (Singleton jDoc) =
+            <@@ JsonRuntime.GetRecordProperties(%%jDoc).Length = 0 @@>            
+
+          [
+            ProvidedProperty("Items", itemsSeqType, getterCode = itemsGetter)
+            ProvidedProperty("Keys", keyResult.ConvertedType.MakeArrayType(), getterCode = keysGetter) 
+            ProvidedProperty("Values", valueResult.ConvertedType.MakeArrayType(), getterCode = valuesGetter) 
+            ProvidedProperty("Item", valueResult.ConvertedType, getterCode = itemGetter, indexParameters = [ProvidedParameter("key", keyResult.ConvertedType)]) 
+            ProvidedProperty("Count", typeof<int>, getterCode = countGetter)
+            ProvidedProperty("IsEmpty", typeof<bool>, getterCode = isEmptyGetter) ]
+          |> objectTy.AddMembers
+          [
+            ProvidedMethod("TryFind",  [ProvidedParameter("key", keyResult.ConvertedType)], valueResult.ConvertedType |> ctx.MakeOptionType, tryFindCode)
+            ProvidedMethod("ContainsKey",  [ProvidedParameter("key", keyResult.ConvertedType)], typeof<bool>, containsKeyCode) ]
+          |> objectTy.AddMembers
+          if ctx.GenerateConstructors then
+            objectTy.AddMember <| 
+              ProvidedConstructor([ProvidedParameter("items", itemsSeqType)], invokeCode = fun args ->
+                let kvSeq = args.Head
+                let conv (value: Expr) =
+                  let value = ProviderHelpers.some keyResult.ConvertedType value
+                  ConversionsGenerator.getBackConversionQuotation "" ctx.CultureStr keyResult.ConvertedType value :> Expr
+                let convFunc =
+                  ReflectionHelpers.makeDelegate conv keyResult.ConvertedType
+
+                let cultureStr = ctx.CultureStr
+                ctx.JsonRuntimeType?CreateRecordFromDictionary (keyResult.ConvertedType, valueConvertedTypeErased) (kvSeq, cultureStr, convFunc) )
+          ()
+        | None ->
+          // Add all record fields as properties
+          let members = 
             [for prop in props ->
 
               let propResult = generateJsonType ctx (*canPassAllConversionCallingTypes*)true (*optionalityHandledByParent*)true "" prop.Type
               let propName = prop.Name
               let optionalityHandledByProperty = propResult.ConversionCallingType <> JsonDocument
 
-              let getter = fun (Singleton jDoc) -> 
+              let getter (Singleton jDoc) =
 
                 if optionalityHandledByProperty then 
 
@@ -336,29 +422,30 @@ module JsonTypeBuilder =
 
               let name = makeUnique prop.Name
               prop.Name,
-              ProvidedProperty(name, convertedType, getterCode = getter),
+              [ProvidedProperty(name, convertedType, getterCode = getter)],
               ProvidedParameter(NameUtils.niceCamelName name, replaceJDocWithJValue ctx convertedType) ]
 
-        let names, properties, parameters = List.unzip3 members
-        objectTy.AddMembers properties
-
-        if ctx.GenerateConstructors then
+          let names, properties, parameters = List.unzip3 members
+          let properties = properties |> List.concat
+          objectTy.AddMembers properties
 
+          if ctx.GenerateConstructors then
             objectTy.AddMember <| 
-                ProvidedConstructor(parameters, invokeCode = fun args -> 
-                    let properties = 
-                        Expr.NewArray(typeof<string * obj>, 
-                                      args 
-                                      |> List.mapi (fun i a -> Expr.NewTuple [ Expr.Value names.[i]; Expr.Coerce(a, typeof<obj>) ]))
-                    let cultureStr = ctx.CultureStr
-                    <@@ JsonRuntime.CreateRecord(%%properties, cultureStr) @@>)
+              ProvidedConstructor(parameters, invokeCode = fun args ->
+                let properties = 
+                    Expr.NewArray(typeof<string * obj>, 
+                                  args 
+                                  |> List.mapi (fun i a -> Expr.NewTuple [ Expr.Value names.[i]; Expr.Coerce(a, typeof<obj>) ]))
+                let cultureStr = ctx.CultureStr
+                <@@ JsonRuntime.CreateRecord(%%properties, cultureStr) @@>)
+          ()
 
+        if ctx.GenerateConstructors then
             objectTy.AddMember <| 
                     ProvidedConstructor(
                         [ProvidedParameter("jsonValue", ctx.JsonValueType)], 
                         invokeCode = fun (Singleton arg) -> 
                             <@@ JsonDocument.Create((%%arg:JsonValue), "") @@> )
-
         objectTy
 
     | InferedType.Collection (_, types) -> getOrCreateType ctx inferedType <| fun () ->

src/Json/JsonProvider.fs

@@ -39,6 +39,7 @@ type public JsonProvider(cfg:TypeProviderConfig) as this =
         let resolutionFolder = args.[5] :?> string
         let resource = args.[6] :?> string
         let inferTypesFromValues = args.[7] :?> bool
+        let preferDictionaries = args.[8] :?> bool
 
         let cultureInfo = TextRuntime.GetCulture cultureStr
 
@@ -58,7 +59,7 @@ type public JsonProvider(cfg:TypeProviderConfig) as this =
 
             using (IO.logTime "TypeGeneration" sample) <| fun _ ->
 
-                let ctx = JsonGenerationContext.Create(cultureStr, tpType)
+                let ctx = JsonGenerationContext.Create(cultureStr, tpType, ?preferDictionaries = Some preferDictionaries)
                 let result = JsonTypeBuilder.generateJsonType ctx (*canPassAllConversionCallingTypes*)false (*optionalityHandledByParent*)false rootName inferedType
 
                 { GeneratedType = tpType
@@ -89,7 +90,8 @@ type public JsonProvider(cfg:TypeProviderConfig) as this =
           ProvidedStaticParameter("Encoding", typeof<string>, parameterDefaultValue = "") 
           ProvidedStaticParameter("ResolutionFolder", typeof<string>, parameterDefaultValue = "")
           ProvidedStaticParameter("EmbeddedResource", typeof<string>, parameterDefaultValue = "")
-          ProvidedStaticParameter("InferTypesFromValues", typeof<bool>, parameterDefaultValue = true) ]
+          ProvidedStaticParameter("InferTypesFromValues", typeof<bool>, parameterDefaultValue = true)
+          ProvidedStaticParameter("PreferDictionaries", typeof<bool>, parameterDefaultValue = false) ]
 
     let helpText = 
         """<summary>Typed representation of a JSON document.</summary>
@@ -102,7 +104,8 @@ type public JsonProvider(cfg:TypeProviderConfig) as this =
            <param name='EmbeddedResource'>When specified, the type provider first attempts to load the sample from the specified resource 
               (e.g. 'MyCompany.MyAssembly, resource_name.json'). This is useful when exposing types generated by the type provider.</param>
            <param name='InferTypesFromValues'>If true, turns on additional type inference from values. 
-              (e.g. type inference infers string values such as "123" as ints and values constrained to 0 and 1 as booleans.)</param>"""
+              (e.g. type inference infers string values such as "123" as ints and values constrained to 0 and 1 as booleans.)</param>
+           <param name='PreferDictionaries'>If true, json record is considered as a dictionary, if the names of all the its fields are infered (by type inference rules) into the same non-string primitive type.</param>"""
 
     do jsonProvTy.AddXmlDoc helpText
     do jsonProvTy.DefineStaticParameters(parameters, buildTypes)

src/Json/JsonRuntime.fs

@@ -157,6 +157,56 @@ type JsonRuntime =
     | JsonValue.Null -> [| |]
     | x -> failwithf "Expecting an array at '%s', got %s" (doc.Path()) <| x.ToString(JsonSaveOptions.DisableFormatting)
 
+  /// Get properties of the record
+  static member GetRecordProperties(doc:IJsonDocument) =
+    match doc.JsonValue with     
+    | JsonValue.Record items -> items
+    | JsonValue.Null -> [||]
+    | x -> failwithf "Expecting a record at '%s', got %s" (doc.Path()) <| x.ToString(JsonSaveOptions.DisableFormatting)
+
+  /// Converts JSON record to dictionary
+  static member ConvertRecordToDictionary<'Key, 'Value when 'Key: equality>(doc:IJsonDocument, mappingKey:Func<IJsonDocument,'Key>, mappingValue:Func<IJsonDocument,'Value>) = 
+    JsonRuntime.GetRecordProperties(doc)
+    |> Seq.map (fun (k, v) -> 
+                  let key = doc.CreateNew(JsonValue.String k, k) |> mappingKey.Invoke
+                  let value = doc.CreateNew(v, k) |> mappingValue.Invoke
+                  key, value)
+
+
+  /// Get a value by the key from infered dictionary
+  static member InferedDictionaryContainsKey<'Key when 'Key: equality>(doc:IJsonDocument, mappingKey:Func<IJsonDocument,'Key>, key: 'Key) = 
+    let finder (k, _) =
+      (doc.CreateNew(JsonValue.String k, k) |> mappingKey.Invoke) = key
+    (JsonRuntime.GetRecordProperties(doc) |> Array.tryFind finder).IsSome
+
+  /// Try get a value by the key from infered dictionary
+  static member TryGetValueByKeyFromInferedDictionary<'Key, 'Value when 'Key: equality>(doc:IJsonDocument, mappingKey:Func<IJsonDocument,'Key>, mappingValue:Func<IJsonDocument,'Value>, key: 'Key) = 
+    let picker (k, v) =
+      if (doc.CreateNew(JsonValue.String k, k) |> mappingKey.Invoke) = key then
+        doc.CreateNew(v, k) |> mappingValue.Invoke |> Some
+      else  
+        None
+    JsonRuntime.GetRecordProperties(doc) |> Array.tryPick picker 
+
+  /// Get a value by the key from infered dictionary
+  static member GetValueByKeyFromInferedDictionary<'Key, 'Value when 'Key: equality>(doc:IJsonDocument, mappingKey:Func<IJsonDocument,'Key>, mappingValue:Func<IJsonDocument,'Value>, key: 'Key) = 
+    match JsonRuntime.TryGetValueByKeyFromInferedDictionary(doc, mappingKey, mappingValue, key) with
+    | Some value -> value
+    | _ ->  key 
+            |> sprintf "The given key '%A' was not present in the dictionary." 
+            |> System.Collections.Generic.KeyNotFoundException 
+            |> raise
+
+  /// Get keys from infered dictionary
+  static member GetKeysFromInferedDictionary<'Key when 'Key: equality>(doc:IJsonDocument, mappingKey:Func<IJsonDocument,'Key>) = 
+    JsonRuntime.GetRecordProperties(doc) 
+    |> Array.map (fun (k, _) -> doc.CreateNew(JsonValue.String k, k) |> mappingKey.Invoke)
+
+  /// Get values from infered dictionary
+  static member GetValuesFromInferedDictionary<'Value>(doc:IJsonDocument, mappingValue:Func<IJsonDocument,'Value>) = 
+    JsonRuntime.GetRecordProperties(doc) 
+    |> Array.map (fun (k, v) -> doc.CreateNew(v, k) |> mappingValue.Invoke)
+
   /// Get optional json property
   static member TryGetPropertyUnpacked(doc:IJsonDocument, name) =
     doc.JsonValue.TryGetProperty(name)
@@ -301,6 +351,16 @@ type JsonRuntime =
       |> JsonValue.Record
     JsonDocument.Create(json, "")
 
+  // Creates a JsonValue.Record from key*value seq and wraps it in a json document
+  static member CreateRecordFromDictionary<'Key, 'Value when 'Key: equality>(keyValuePairs: ('Key * 'Value) seq, cultureStr, mappingKeyBack: Func<'Key, string>) =
+    let cultureInfo = TextRuntime.GetCulture cultureStr
+    let json = 
+      keyValuePairs 
+      |> Seq.map (fun (k, v) -> (k |> mappingKeyBack.Invoke), JsonRuntime.ToJsonValue cultureInfo (v :> obj))
+      |> Seq.toArray
+      |> JsonValue.Record
+    JsonDocument.Create(json, "")
+
   /// Creates a scalar JsonValue.Array and wraps it in a json document
   static member CreateArray(elements:obj[], cultureStr) =
     let cultureInfo = TextRuntime.GetCulture cultureStr

src/Test.fsx

@@ -66,7 +66,8 @@ Json { Sample = "optionals.json"
        Encoding = ""
        ResolutionFolder = ""
        EmbeddedResource = ""
-       InferTypesFromValues = true }
+       InferTypesFromValues = true
+       PreferDictionaries = false }
 |> dumpAll
 
 Xml { Sample = "JsonInXml.xml"      

tests/FSharp.Data.DesignTime.Tests/SignatureTestCases.config

@@ -35,27 +35,29 @@ Xml,TimeSpans.xml,false,false,,true,
 Xml,,false,false,,false,po.xsd
 Xml,,false,false,,false,homonim.xsd
 Xml,,false,false,,false,IncludeFromWeb.xsd
-Json,WorldBank.json,false,WorldBank,,true
-Json,TwitterStream.json,true,,,true
-Json,TwitterSample.json,true,,,true
-Json,OptionValues.json,false,,,true
-Json,SimpleArray.json,false,,,true
-Json,DoubleNested.json,false,,,true
-Json,Nested.json,false,,,true
-Json,Simple.json,false,,,true
-Json,WikiData.json,false,,,true
-Json,Empty.json,false,,,true
-Json,projects.json,false,,,true
-Json,Dates.json,false,,,true
-Json,GitHub.json,false,,,true
-Json,topics.json,true,Topic,,true
-Json,Vindinium.json,false,,,true
-Json,contacts.json,false,,,true
-Json,optionals.json,false,,,true
-Json,reddit.json,false,,,true
-Json,TypeInference.json,false,,,true
-Json,TypeInference.json,false,,,false
-Json,TimeSpans.json,false,,,true
+Json,WorldBank.json,false,WorldBank,,true,false,false
+Json,TwitterStream.json,true,,,true,false
+Json,TwitterSample.json,true,,,true,false
+Json,OptionValues.json,false,,,true,false
+Json,SimpleArray.json,false,,,true,false
+Json,DoubleNested.json,false,,,true,false
+Json,Nested.json,false,,,true,false
+Json,Simple.json,false,,,true,false
+Json,WikiData.json,false,,,true,false
+Json,Empty.json,false,,,true,false
+Json,projects.json,false,,,true,false
+Json,Dates.json,false,,,true,false
+Json,GitHub.json,false,,,true,false
+Json,topics.json,true,Topic,,true,false
+Json,Vindinium.json,false,,,true,false
+Json,contacts.json,false,,,true,false
+Json,optionals.json,false,,,true,false
+Json,reddit.json,false,,,true,false
+Json,TypeInference.json,false,,,true,false
+Json,TypeInference.json,false,,,false,false
+Json,TimeSpans.json,false,,,true,false
+Json,DictionaryInference.json,false,,,true,false
+Json,DictionaryInference.json,false,,,true,true
 Html,MarketDepth.htm,false,false,
 Html,MarketDepth.htm,true,false,
 Html,SimpleHtmlTablesWithTr.html,false,false,

tests/FSharp.Data.DesignTime.Tests/TypeProviderInstantiation.fs

@@ -44,7 +44,8 @@ type JsonProviderArgs =
       Encoding : string
       ResolutionFolder : string
       EmbeddedResource : string
-      InferTypesFromValues : bool }
+      InferTypesFromValues : bool
+      PreferDictionaries : bool }
 
 type HtmlProviderArgs =
     { Sample : string
@@ -110,7 +111,8 @@ type TypeProviderInstantiation =
                    box x.Encoding
                    box x.ResolutionFolder
                    box x.EmbeddedResource
-                   box x.InferTypesFromValues |]
+                   box x.InferTypesFromValues
+                   box x.PreferDictionaries |]
             | Html x ->
                 (fun cfg -> new HtmlProvider(cfg) :> TypeProviderForNamespaces),
                 [| box x.Sample
@@ -155,7 +157,8 @@ type TypeProviderInstantiation =
              x.SampleIsList.ToString()
              x.RootName
              x.Culture
-             x.InferTypesFromValues.ToString() ]
+             x.InferTypesFromValues.ToString()
+             x.PreferDictionaries.ToString() ]
         | Html x ->
             ["Html"
              x.Sample
@@ -223,7 +226,8 @@ type TypeProviderInstantiation =
                    Encoding = ""
                    ResolutionFolder = ""
                    EmbeddedResource = ""
-                   InferTypesFromValues = args.[5] |> bool.Parse }
+                   InferTypesFromValues = args.[5] |> bool.Parse
+                   PreferDictionaries = args.[6] |> bool.Parse }
         | "Html" ->
             Html { Sample = args.[1]
                    PreferOptionals = args.[2] |> bool.Parse