1+ module Ionide.LanguageServerProtocol.JsonUtils
2+
3+ open Microsoft.FSharp .Reflection
4+ open Newtonsoft.Json
5+ open System
6+ open System.Collections .Concurrent
7+ open Ionide.LanguageServerProtocol .Types
8+ open Newtonsoft.Json .Linq
9+ open Newtonsoft.Json .Serialization
10+ open System.Reflection
11+
12+ module Type =
13+ let numerics =
14+ [| typeof< int>
15+ typeof< float>
16+ typeof< byte>
17+ typeof< uint>
18+ //ENHANCEMENT: other number types
19+ |]
20+
21+ let numericHashes = numerics |> Array.map ( fun t -> t.GetHashCode())
22+ let stringHash = typeof< string>. GetHashCode ()
23+ let boolHash = typeof< bool>. GetHashCode ()
24+
25+ let inline isOption ( t : Type ) =
26+ t.IsGenericType
27+ && t.GetGenericTypeDefinition() = typedefof<_ option>
28+
29+ let inline isString ( t : Type ) = t.GetHashCode() = stringHash
30+ let inline isBool ( t : Type ) = t.GetHashCode() = boolHash
31+
32+ let inline isNumeric ( t : Type ) =
33+ let hash = t.GetHashCode()
34+ numericHashes |> Array.contains hash
35+
36+ /// Handles fields of type `Option`:
37+ /// * Allows missing json properties when `Option` -> Optional
38+ /// * Fails when missing json property when not `Option` -> Required
39+ /// * Additional properties in json are always ignored
40+ ///
41+ /// Example:
42+ /// ```fsharp
43+ /// type Data = { Name: string; Value: int option }
44+ /// ```
45+ /// ```json
46+ /// { "name": "foo", "value": 42 } // ok
47+ /// { "name": "foo" } // ok
48+ /// { "value": 42 } // error
49+ /// {} // error
50+ /// { "name": "foo", "data": "bar" } // ok
51+ /// ```
52+ [<Sealed>]
53+ type OptionAndCamelCasePropertyNamesContractResolver () as this =
54+ inherit CamelCasePropertyNamesContractResolver()
55+
56+ do this.NamingStrategy.ProcessDictionaryKeys <- false
57+
58+ let isOptionType ( ty : Type ) =
59+ ty.IsGenericType
60+ && ty.GetGenericTypeDefinition() = typedefof< Option<_>>
61+
62+ override _.CreateProperty ( memberInfo , memberSerialization ) =
63+ // mutable properties in records have their corresponding field deserialized too
64+ // field has postfix `@`
65+ // -> exclude everything ending in `@` (-> ~ private fields)
66+ if memberInfo.Name.EndsWith " @" then
67+ null
68+ else
69+ let prop = `` base `` ( memberInfo, memberSerialization)
70+
71+ let shouldUpdateRequired =
72+ // change nothing when specified:
73+ // * `JsonProperty.Required`
74+ // * Don't know if specified -> compare with `Default`
75+ match memberInfo.GetCustomAttribute< JsonPropertyAttribute>() with
76+ | null -> true
77+ | jp -> jp.Required = Required.Default
78+
79+ if shouldUpdateRequired then
80+ if Type.isOption prop.PropertyType then
81+ prop.Required <- Required.Default
82+ else
83+ prop.Required <- Required.Always
84+
85+ prop
86+
87+
88+ let inline private memorise ( f : 'a -> 'b ) : 'a -> 'b =
89+ let d = ConcurrentDictionary< 'a, 'b>()
90+ fun key -> d.GetOrAdd( key, f)
91+
92+ let inline private memoriseByHash ( f : 'a -> 'b ) : 'a -> 'b =
93+ let d = ConcurrentDictionary< int, 'b>()
94+
95+ fun key ->
96+ let hash = key.GetHashCode()
97+
98+ match d.TryGetValue( hash) with
99+ | ( true , value) -> value
100+ | _ ->
101+ let value = f key
102+ d.TryAdd( hash, value) |> ignore
103+ value
104+
105+ type private CaseInfo =
106+ { Info: UnionCaseInfo
107+ Fields: PropertyInfo []
108+ GetFieldValues: obj -> obj []
109+ Create: obj [] -> obj }
110+
111+ type private UnionInfo =
112+ { Cases: CaseInfo []
113+ GetTag: obj -> int }
114+ member u.GetCaseOf ( value : obj ) =
115+ let tag = u.GetTag value
116+ u.Cases |> Array.find ( fun case -> case.Info.Tag = tag)
117+
118+ module private UnionInfo =
119+ let private create ( ty : Type ) =
120+ assert ( ty |> FSharpType.IsUnion)
121+
122+ let cases =
123+ FSharpType.GetUnionCases ty
124+ |> Array.map ( fun case ->
125+ { Info = case
126+ Fields = case.GetFields()
127+ GetFieldValues = FSharpValue.PreComputeUnionReader case
128+ Create = FSharpValue.PreComputeUnionConstructor case })
129+
130+ { Cases = cases; GetTag = FSharpValue.PreComputeUnionTagReader ty }
131+
132+ let get : Type -> _ = memoriseByHash ( create)
133+
134+ /// Newtonsoft.Json parses parses a number inside quotations as number too:
135+ /// `"42"` -> can be parsed to `42: int`
136+ /// This converter prevents that. `"42"` cannot be parsed to `int` (or `float`) any more
137+ [<Sealed>]
138+ type StrictNumberConverter () =
139+ inherit JsonConverter()
140+
141+ static let defaultSerializer = JsonSerializer()
142+
143+ override _.CanConvert ( t ) = t |> Type.isNumeric
144+
145+ override __.ReadJson ( reader , t , _ , serializer ) =
146+ match reader.TokenType with
147+ | JsonToken.Integer
148+ | JsonToken.Float ->
149+ // cannot use `serializer`: Endless recursion into StrictNumberConverter for same value
150+ defaultSerializer.Deserialize( reader, t)
151+ | _ -> failwith $" Expected a number, but was {reader.TokenType}"
152+
153+ override _.CanWrite = false
154+ override _.WriteJson ( _ , _ , _ ) = raise ( NotImplementedException())
155+
156+ /// Like `StrictNumberConverter`, but prevents numbers to be parsed as string:
157+ /// `42` -> no quotation marks -> not a string
158+ [<Sealed>]
159+ type StrictStringConverter () =
160+ inherit JsonConverter()
161+
162+ override _.CanConvert ( t ) = t |> Type.isString
163+
164+ override __.ReadJson ( reader , t , _ , serializer ) =
165+ match reader.TokenType with
166+ | JsonToken.String -> reader.Value
167+ | JsonToken.Null -> null
168+ | _ -> failwith $" Expected a string, but was {reader.TokenType}"
169+
170+ override _.CanWrite = false
171+ override _.WriteJson ( _ , _ , _ ) = raise ( NotImplementedException())
172+
173+ /// Like `StrictNumberConverter`, but prevents boolean to be parsed as string:
174+ /// `true` -> no quotation marks -> not a string
175+ [<Sealed>]
176+ type StrictBoolConverter () =
177+ inherit JsonConverter()
178+
179+ override _.CanConvert ( t ) = t |> Type.isBool
180+
181+ override __.ReadJson ( reader , t , _ , serializer ) =
182+ match reader.TokenType with
183+ | JsonToken.Boolean -> reader.Value
184+ | _ -> failwith $" Expected a bool, but was {reader.TokenType}"
185+
186+ override _.CanWrite = false
187+ override _.WriteJson ( _ , _ , _ ) = raise ( NotImplementedException())
188+
189+ [<Sealed>]
190+ type ErasedUnionConverter () =
191+ inherit JsonConverter()
192+
193+ let canConvert =
194+ memoriseByHash ( fun t ->
195+ FSharpType.IsUnion t
196+ && (
197+ // Union
198+ t.GetCustomAttributes( typedefof< ErasedUnionAttribute>, false ) .Length > 0
199+ ||
200+ // Case
201+ t.BaseType.GetCustomAttributes( typedefof< ErasedUnionAttribute>, false ) .Length > 0 ))
202+
203+ override __.CanConvert ( t ) = canConvert t
204+
205+ override __.WriteJson ( writer , value , serializer ) =
206+ let union = UnionInfo.get ( value.GetType())
207+ let case = union.GetCaseOf value
208+ // Must be exactly 1 field
209+ // Deliberately fail here to signal incorrect usage
210+ // (vs. `CanConvert` = `false` -> silent and fallback to serialization with `case` & `fields`)
211+ match case.GetFieldValues value with
212+ | [| value |] -> serializer.Serialize( writer, value)
213+ | values -> failwith $" Expected exactly one field for case `{value.GetType().Name}`, but were {values.Length}"
214+
215+ override __.ReadJson ( reader : JsonReader , t , _existingValue , serializer ) =
216+ let tryReadValue ( json : JToken ) ( targetType : Type ) =
217+ if Type.isString targetType then
218+ if json.Type = JTokenType.String then
219+ reader.Value |> Some
220+ else
221+ None
222+ elif Type.isBool targetType then
223+ if json.Type = JTokenType.Boolean then
224+ reader.Value |> Some
225+ else
226+ None
227+ elif Type.isNumeric targetType then
228+ match json.Type with
229+ | JTokenType.Integer
230+ | JTokenType.Float -> json.ToObject( targetType, serializer) |> Some
231+ | _ -> None
232+ else
233+ try
234+ json.ToObject( targetType, serializer) |> Some
235+ with
236+ | _ -> None
237+
238+ let union = UnionInfo.get t
239+ let json = JToken.ReadFrom reader
240+
241+ let tryMakeUnionCase ( json : JToken ) ( case : CaseInfo ) =
242+ match case.Fields with
243+ | [| field |] ->
244+ let ty = field.PropertyType
245+
246+ match tryReadValue json ty with
247+ | None -> None
248+ | Some value -> case.Create [| value |] |> Some
249+ | fields ->
250+ failwith
251+ $" Expected union {case.Info.DeclaringType.Name} to have exactly one field in each case, but case {case.Info.Name} has {fields.Length} fields"
252+
253+ let c = union.Cases |> Array.tryPick ( tryMakeUnionCase json)
254+
255+ match c with
256+ | None -> failwith $" Could not create an instance of the type '%s "
257+ | Some c -> c
258+
259+ /// converter that can convert enum-style DUs
260+ [<Sealed>]
261+ type SingleCaseUnionConverter () =
262+ inherit JsonConverter()
263+
264+ let canConvert =
265+ let allCases ( t : System.Type ) = FSharpType.GetUnionCases t
266+
267+ memoriseByHash ( fun t ->
268+ FSharpType.IsUnion t
269+ && allCases t
270+ |> Array.forall ( fun c -> c.GetFields() .Length = 0 ))
271+
272+ override _.CanConvert t = canConvert t
273+
274+ override _.WriteJson ( writer : Newtonsoft.Json.JsonWriter , value : obj , serializer : Newtonsoft.Json.JsonSerializer ) =
275+ serializer.Serialize( writer, string value)
276+
277+ override _.ReadJson ( reader : Newtonsoft.Json.JsonReader , t , _existingValue , serializer ) =
278+ let caseName = string reader.Value
279+
280+ let union = UnionInfo.get t
281+
282+ let case =
283+ union.Cases
284+ |> Array.tryFind ( fun c -> c.Info.Name.Equals( caseName, StringComparison.OrdinalIgnoreCase))
285+
286+ match case with
287+ | Some case -> case.Create [||]
288+ | None -> failwith $" Could not create an instance of the type '%s %s "
289+
290+ [<Sealed>]
291+ type OptionConverter () =
292+ inherit JsonConverter()
293+
294+ let getInnerType =
295+ memoriseByHash ( fun ( t : Type ) ->
296+ let innerType = t.GetGenericArguments()[ 0 ]
297+
298+ if innerType.IsValueType then
299+ typedefof< Nullable<_>>. MakeGenericType ([| innerType |])
300+ else
301+ innerType)
302+
303+ let canConvert = memoriseByHash ( Type.isOption)
304+
305+ override __.CanConvert ( t ) = canConvert t
306+
307+ override __.WriteJson ( writer , value , serializer ) =
308+ let value =
309+ if isNull value then
310+ null
311+ else
312+ let union = UnionInfo.get ( value.GetType())
313+ let case = union.GetCaseOf value
314+ case.GetFieldValues value |> Array.head
315+
316+ serializer.Serialize( writer, value)
317+
318+ override __.ReadJson ( reader , t , _existingValue , serializer ) =
319+ match reader.TokenType with
320+ | JsonToken.Null -> null // = None
321+ | _ ->
322+ let innerType = getInnerType t
323+
324+ let value = serializer.Deserialize( reader, innerType)
325+
326+ if isNull value then
327+ null
328+ else
329+ let union = UnionInfo.get t
330+ union.Cases[ 1 ]. Create [| value |]
0 commit comments