Created
May 29, 2017 10:47
-
-
Save fpawel/e9170e9ce0c4e6a4a913d0c73a149a9e to your computer and use it in GitHub Desktop.
Json in F#
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
namespace Json | |
open System | |
open System.Text | |
open System.Globalization | |
open FParsec | |
type Json = | |
| String of string | |
| Number of decimal | |
| Bool of bool | |
| Null of unit | |
| Array of Json list | |
| Object of Map<string, Json> | |
static member obj = Map.ofList >> Object | |
static member empty = Map.empty |> Object | |
[<AutoOpen>] | |
module Helpers = | |
let prop key = function | |
| Object x -> x |> Map.tryFind key | |
| _ -> None | |
let (|Prop|_|) key = prop key | |
let (|Props|_|) keys json = | |
match json with | |
| Object x -> | |
let r = | |
keys | |
|> List.map( fun key -> Map.tryFind key x ) | |
|> List.choose id | |
if r.Length = keys.Length then Some r else None | |
| _ -> None | |
let (|StringInt|_|) = function | |
| String x -> | |
let b,x = Int32.TryParse x | |
if b then Some x else None | |
| _ -> None | |
let (|StringInt64|_|) = function | |
| String x -> | |
let b,x = Int64.TryParse x | |
if b then Some x else None | |
| _ -> None | |
let (|Int32|_|) = function | |
| Number x when Decimal.Round(x)=x -> x |> Decimal.ToInt32 |> Some | |
| _ -> None | |
(* Functional | |
Functional signatures for working with Json types, implying a monadic | |
approach to working with Json where appropriate. | |
Additionally includes common functions for combining and creating | |
functions of type Json<'a> which may be used via operator based | |
combinators or a computation expression (both provided later). *) | |
[<AutoOpen>] | |
module Functional = | |
type Json<'a> = | |
Json -> JsonResult<'a> * Json | |
and JsonResult<'a> = | |
| Value of 'a | |
| Error of string | |
(* Functions | |
Common functions for combining Json<'a> functions in to new | |
forms, and for creating new Json<'a> functions given suitable | |
initial data. *) | |
[<RequireQualifiedAccess>] | |
module Json = | |
let inline init (a: 'a) : Json<'a> = | |
fun json -> | |
Value a, json | |
let inline error (e: string) : Json<'a> = | |
fun json -> | |
Error e, json | |
let inline internal ofResult result = | |
fun json -> | |
result, json | |
let inline bind (m: Json<'a>) (f: 'a -> Json<'b>) : Json<'b> = | |
fun json -> | |
match m json with | |
| Value a, json -> (f a) json | |
| Error e, json -> Error e, json | |
let inline apply (f: Json<'a -> 'b>) (m: Json<'a>) : Json<'b> = | |
bind f (fun f' -> | |
bind m (fun m' -> | |
init (f' m'))) | |
let inline map (f: 'a -> 'b) (m: Json<'a>) : Json<'b> = | |
bind m (fun m' -> | |
init (f m')) | |
let inline map2 (f: 'a -> 'b -> 'c) (m1: Json<'a>) (m2: Json<'b>) : Json<'c> = | |
apply (apply (init f) m1) m2 | |
(* Escaping | |
Functions for escaped string parsing and formatting, as a | |
minimal encoding function (escaping only disallowed codepoints, | |
but normalizing any input). *) | |
module private Escaping = | |
let private digit i = | |
(i >= 0x30 && i <= 0x39) | |
let private hexdig i = | |
(digit i) | |
|| (i >= 0x41 && i <= 0x46) | |
|| (i >= 0x61 && i <= 0x66) | |
let private unescaped i = | |
i >= 0x20 && i <= 0x21 | |
|| i >= 0x23 && i <= 0x5b | |
|| i >= 0x5d && i <= 0x10ffff | |
let private unescapedP = | |
satisfy (int >> unescaped) | |
let private hexdig4P = | |
manyMinMaxSatisfy 4 4 (int >> hexdig) | |
|>> fun s -> | |
char (Int32.Parse (s, NumberStyles.HexNumber)) | |
let private escapedP = | |
skipChar '\\' | |
>>. choice [ | |
pchar '"' | |
pchar '\\' | |
pchar '/' | |
skipChar 'b' >>% '\u0008' | |
skipChar 'f' >>% '\u000c' | |
skipChar 'n' >>% '\u000a' | |
skipChar 'r' >>% '\u000d' | |
skipChar 't' >>% '\u0009' | |
skipChar 'u' >>. hexdig4P ] | |
let private charP = | |
choice [ | |
unescapedP | |
escapedP ] | |
let parse = | |
many charP | |
let escape (s: string) = | |
let rec escape r = | |
function | [] -> r | |
| h :: t when (unescaped (int h)) -> | |
escape (r @ [ h ]) t | |
| h :: t -> | |
let n = | |
match h with | |
| '"' -> [ '\\'; '"' ] | |
| '\\' -> [ '\\'; '\\' ] | |
| '\b' -> [ '\\'; 'b' ] | |
| '\f' -> [ '\\'; 'f' ] | |
| '\n' -> [ '\\'; 'n' ] | |
| '\r' -> [ '\\'; 'r' ] | |
| '\t' -> [ '\\'; 't' ] | |
| x -> [ '\\'; 'u' ] @ [ for c in (((int x).ToString ("X4")).ToCharArray ()) -> c ] | |
escape (r @ n) t | |
new string (List.toArray (escape [] [ for c in (s.ToCharArray ()) -> c ])) | |
module private Parsing = | |
(* Helpers | |
Utlility functions for working with intermediate states of | |
parsers, minimizing boilerplate and unpleasant code. *) | |
let emp = | |
function | Some x -> x | |
| _ -> "" | |
(* Grammar | |
Common grammatical elements forming parts of other parsers as | |
as defined in RFC 1759. The elements are implemented slightly | |
differently due to the design of parser combinators used, chiefly | |
concerning whitespace, which is always implemented as trailing. | |
Taken from RFC 7159, Section 2 Grammar | |
See [http://tools.ietf.org/html/rfc7159#section-2] *) | |
let wsp i = | |
i = 0x20 | |
|| i = 0x09 | |
|| i = 0x0a | |
|| i = 0x0d | |
let wspP = | |
skipManySatisfy (int >> wsp) | |
let charWspP c = | |
skipChar c .>> wspP | |
let beginArrayP = | |
charWspP '[' | |
let beginObjectP = | |
charWspP '{' | |
let endArrayP = | |
charWspP ']' | |
let endObjectP = | |
charWspP '}' | |
let nameSeparatorP = | |
charWspP ':' | |
let valueSeparatorP = | |
charWspP ',' | |
(* JSON | |
As the JSON grammar is recursive in various forms, we create a | |
reference parser which will be assigned later, allowing for recursive | |
definition of parsing rules. *) | |
let jsonP, jsonR = | |
createParserForwardedToRef () | |
(* Values | |
Taken from RFC 7159, Section 3 Values | |
See [http://tools.ietf.org/html/rfc7159#section-3] *) | |
let boolP = | |
stringReturn "true" true | |
<|> stringReturn "false" false | |
.>> wspP | |
let nullP = | |
stringReturn "null" () .>> wspP | |
(* Numbers | |
The numbers parser is implemented by parsing the JSON number value | |
in to a known representation valid as string under Double.Parse | |
natively (invoked as the float conversion function on the eventual | |
string). | |
Taken from RFC 7159, Section 6 Numbers | |
See [http://tools.ietf.org/html/rfc7159#section-6] *) | |
let digit1to9 i = | |
i >= 0x31 && i <= 0x39 | |
let digit i = | |
digit1to9 i | |
|| i = 0x30 | |
let e i = | |
i = 0x45 | |
|| i = 0x65 | |
let minusP = | |
charReturn '-' "-" | |
let intP = | |
charReturn '0' "0" <|> (satisfy (int >> digit1to9) .>>. manySatisfy (int >> digit) | |
|>> fun (h, t) -> string h + t) | |
let fracP = | |
skipChar '.' >>. many1Satisfy (int >> digit) | |
|>> fun i -> "." + i | |
let expP = | |
skipSatisfy (int >> e) | |
>>. opt (charReturn '-' "-" <|> charReturn '+' "+") | |
.>>. many1Satisfy (int >> digit) | |
|>> function | Some s, d -> "e" + s + d | |
| _, d -> "e" + d | |
let numberP = | |
pipe4 (opt minusP) intP (opt fracP) (opt expP) (fun m i f e -> | |
decimal (emp m + i + emp f + emp e)) .>> wspP | |
(* Strings | |
Taken from RFC 7159, Section 7 Strings | |
See [http://tools.ietf.org/html/rfc7159#section-7] *) | |
let quotationMarkP = | |
skipChar '"' | |
let stringP = | |
between quotationMarkP quotationMarkP Escaping.parse .>> wspP | |
|>> fun cs -> new string (List.toArray cs) | |
(* Objects | |
Taken from RFC 7159, Section 4 Objects | |
See [http://tools.ietf.org/html/rfc7159#section-4] *) | |
let memberP = | |
stringP .>> nameSeparatorP .>>. jsonP | |
let objectP = | |
between beginObjectP endObjectP (sepBy memberP valueSeparatorP) | |
|>> Map.ofList | |
(* Arrays | |
Taken from RFC 7159, Section 5 Arrays | |
See [http://tools.ietf.org/html/rfc7159#section-5] *) | |
let arrayP = | |
between beginArrayP endArrayP (sepBy jsonP valueSeparatorP) | |
(* JSON *) | |
do jsonR := | |
wspP | |
>>. choice [ | |
arrayP |>> Array | |
boolP |>> Bool | |
nullP |>> Null | |
numberP |>> Number | |
objectP |>> Object | |
stringP |>> String ] | |
(* Formatting *) | |
[<AutoOpen>] | |
module Formatting = | |
(* Helpers *) | |
type private Formatter<'a> = | |
'a -> StringBuilder -> StringBuilder | |
type private Separator = | |
StringBuilder -> StringBuilder | |
let private append (s: string) (b: StringBuilder) = | |
b.Append s | |
let private appendf (s: string) (v1: obj) (b: StringBuilder) = | |
b.AppendFormat (s, v1) | |
let private join<'a> (f: Formatter<'a>) (s: Separator) = | |
let rec join values (b: StringBuilder) = | |
match values with | |
| [] -> b | |
| [v] -> f v b | |
| v :: vs -> (f v >> s >> join vs) b | |
join | |
(* Options | |
Options for formatting, defined as functions for spacing and newline | |
formatting appenders. Predefined formats are given as static members | |
as a shorthand. *) | |
type JsonFormattingOptions = | |
{ Spacing : StringBuilder -> StringBuilder | |
NewLine : int -> StringBuilder -> StringBuilder } | |
static member Compact = | |
{ Spacing = id | |
NewLine = fun _ x -> x } | |
static member SingleLine = | |
{ Spacing = append " " | |
NewLine = fun _ -> append " " } | |
static member Pretty = | |
{ Spacing = append " " | |
NewLine = fun level -> append "\n" >> append (String.replicate level " ") } | |
(* Formatters *) | |
let notNull = function Json.Null () -> false | _ -> true | |
let rec formatJson level options = | |
function | Array x -> formatArray level options x | |
| Bool x -> formatBool x | |
| Number x -> formatNumber x | |
| Null _ -> formatNull () | |
| Object x -> formatObject level options x | |
| String x -> formatString x | |
and private formatArray level options = | |
function | x -> | |
append "[" | |
>> options.NewLine (level + 1) | |
>> join (formatJson (level + 1) options) (append "," >> options.NewLine (level + 1)) x | |
>> options.NewLine level | |
>> append "]" | |
and private formatBool = | |
function | true -> append "true" | |
| _ -> append "false" | |
and private formatNumber = | |
function | x -> append (string x) | |
and private formatNull = | |
function | () -> append "null" | |
and private formatObject level options = | |
function | x -> | |
append "{" | |
>> options.NewLine (level + 1) | |
>> join (fun (k, v) -> appendf "\"{0}\":" (Escaping.escape k) >> options.Spacing >> formatJson (level + 1) options v) | |
(append "," >> options.NewLine (level + 1)) | |
(Map.toList x) | |
>> options.NewLine level | |
>> append "}" | |
and private formatString = | |
function | x -> appendf "\"{0}\"" (Escaping.escape x) | |
[<RequireQualifiedAccess>] | |
module Json = | |
let format json = | |
StringBuilder () | |
|> formatJson 0 JsonFormattingOptions.Compact json | |
|> string | |
let formatWith options json = | |
StringBuilder () | |
|> formatJson 0 options json | |
|> string | |
let stringify = formatWith JsonFormattingOptions.Pretty | |
type Json with | |
static member parse s = | |
match run Parsing.jsonP s with | |
| Success (json, _, _) -> Result.Ok json | |
| Failure (e, _, _) -> Result.Err e | |
static member format json = | |
StringBuilder () | |
|> Formatting.formatJson 0 JsonFormattingOptions.Compact json | |
|> string | |
static member formatWith options json = | |
StringBuilder () | |
|> formatJson 0 options json | |
|> string |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Json.Serialization | |
open System | |
open System.Reflection | |
open Microsoft.FSharp.Reflection | |
[<AutoOpen>] | |
module private Helpers1 = | |
let changeType (x:obj) (tx:Type) : obj = Convert.ChangeType(x, tx) | |
let isStringMap (tx:Type) = | |
let x = tx.GetGenericArguments() | |
tx.IsGenericType && tx.GetGenericTypeDefinition() = typedefof<Map<string,_>> && | |
x.Length=2 && | |
x.[0]=typeof<string> | |
let isMap (type':Type) = | |
type'.IsGenericType && type'.GetGenericTypeDefinition() = typedefof<Map<_,_>> | |
let isOption (type':Type) = | |
type'.IsGenericType && type'.GetGenericTypeDefinition() = typedefof<option<_>> | |
let isSeq (tx:Type) = | |
if not tx.IsGenericType then false else | |
let genType = tx.GetGenericTypeDefinition() | |
genType = typedefof<list<_>> || | |
genType = typedefof<Set<_>> | |
let isList (type':Type) = | |
type'.IsGenericType && type'.GetGenericTypeDefinition() = typedefof<list<_>> | |
let isSet (type':Type) = | |
type'.IsGenericType && type'.GetGenericTypeDefinition() = typedefof<Set<_>> | |
let makeGenericType (baseType : Type) (types : Type list) = | |
if (not baseType.IsGenericTypeDefinition) then | |
invalidArg "baseType" "The base type specified was not a generic type definition." | |
baseType.MakeGenericType ( types |> List.toArray ) | |
let makeListOf itemType (items : obj list) = | |
let listType = | |
makeGenericType | |
<| typedefof<Microsoft.FSharp.Collections.List<_>> | |
<| [ itemType; ] | |
let add = | |
let cons = listType.GetMethod ("Cons") | |
fun item list -> | |
cons.Invoke (null, [| item; list; |]) | |
let list = | |
let empty = listType.GetProperty ("Empty") | |
empty.GetValue (null, [||]) | |
list | |
|> List.foldBack add items | |
let stringify = Json.formatWith JsonFormattingOptions.Pretty | |
let toJsonDefault : obj -> Json option = function | |
| :? string as x -> x |> decimal |> Number |> Some | |
| :? decimal as x -> x |> Number |> Some | |
| :? float as x -> x |> decimal |> Number |> Some | |
| :? single as x -> x |> decimal |> Number |> Some | |
| :? int8 as x -> x |> decimal |> Number |> Some | |
| :? int16 as x -> x |> decimal |> Number |> Some | |
| :? int as x -> x |> decimal |> Number |> Some | |
| :? int64 as x -> x |> decimal |> Number |> Some | |
| :? byte as x -> x |> decimal |> Number |> Some | |
| :? uint16 as x -> x |> decimal |> Number |> Some | |
| :? uint32 as x -> x |> decimal |> Number |> Some | |
| :? uint64 as x -> x |> decimal |> Number |> Some | |
| :? bool as x -> x |> Bool |> Some | |
| :? DateTime as x -> Json.String (x.ToUniversalTime().ToString("o")) |> Some | |
| :? DateTimeOffset as x -> Json.String (x.ToString("o")) |> Some | |
| :? TimeSpan as x -> Json.String (x.ToString( @"hh\:mm\:ss" )) |> Some | |
| _ -> None | |
let (~&&) (type':Type) = type'.Name | |
type SerializationResult = Result<Json,string> | |
module private Serialization = | |
let (==>) x y = x, y |> decimal |> Number | |
let plain' (x : obj) = | |
let (~%%) = Ok >> Some | |
match x with | |
| :? string as x -> %% Json.String x | |
| :? decimal as x -> %% Number x | |
| :? float as x -> %% Number (decimal x) | |
| :? single as x -> %% Number (decimal x) | |
| :? int8 as x -> %% Number (decimal x) | |
| :? int16 as x -> %% Number (decimal x) | |
| :? int as x -> %% Number (decimal x) | |
| :? int64 as x -> %% Number (decimal x) | |
| :? byte as x -> %% Number (decimal x) | |
| :? uint16 as x -> %% Number (decimal x) | |
| :? uint32 as x -> %% Number (decimal x) | |
| :? uint64 as x -> %% Number (decimal x) | |
| :? bool as x -> %% Bool x | |
| :? DateTime as x -> | |
[ "Year" ==> x.Year | |
"Month" ==> x.Month | |
"Day" ==> x.Day | |
"Hour" ==> x.Hour | |
"Minute" ==> x.Minute | |
"Second" ==> x.Second | |
"Millisecond" ==> x.Millisecond ] | |
|> Json.obj |> Ok |> Some | |
| :? TimeSpan as x -> | |
[ "Days" ==> x.Days | |
"Hours" ==> x.Hours | |
"Minutes" ==> x.Minutes | |
"Seconds" ==> x.Seconds | |
"Milliseconds" ==> x.Milliseconds ] | |
|> Json.obj |> Ok |> Some | |
| _ -> None | |
let rec serializeUntyped (x : obj) : SerializationResult = | |
if x=null then Ok (Null ()) else | |
let type' = x.GetType() | |
match plain' x with | |
| Some json -> json | |
| _ -> | |
match trySerializeCustomToJson x with | |
| Some r -> r | |
| _ -> | |
match trySerializeByKnownType x with | |
| Some r -> r | |
| _ -> failwithf "%A : %A, not supported type" x (x.GetType()) | |
and trySerializeCustomToJson (x : obj) : SerializationResult option = | |
let type' = x.GetType() | |
let toJsonUntyped = | |
type'.GetMethod | |
( "ToJsonUntyped", | |
BindingFlags.Public ||| BindingFlags.Static, | |
null, | |
CallingConventions.Any, | |
[| type' |], | |
null ) | |
if toJsonUntyped <> null then | |
toJsonUntyped.Invoke(null, [| box x |] ) :?> Json |> Ok |> Some | |
else None | |
and returnSeq rs = | |
let oks, fails = List.partition Result.isOk rs | |
match fails with | |
| [] -> | |
oks | |
|> List.map Result.Unwrap.ok | |
|> Ok | |
| _ -> | |
fails | |
|> List.map Result.Unwrap.err | |
|> Seq.toStr ";\n" id | |
|> sprintf "error serializing sequence to json: %s" | |
|> Err | |
and returnSeqWith f rs = | |
rs | |
|> returnSeq | |
|> Result.map f | |
and seq' (x:obj) = | |
x :?> System.Collections.IEnumerable | |
|> Seq.cast | |
|> Seq.toList | |
|> List.map serializeUntyped | |
|> returnSeqWith Json.Array | |
and stringMap' (x:obj) = | |
x :?> System.Collections.IEnumerable |> Seq.cast |> Seq.toList |> List.map ( fun keyValueObject -> | |
let keyValueObjectType = keyValueObject.GetType() | |
let keyProp = keyValueObjectType.GetProperty("Key") | |
let kvpKey = string ( keyProp.GetValue(keyValueObject, null) ) | |
let kvpValue = keyValueObjectType.GetProperty("Value").GetValue(keyValueObject, null) | |
match serializeUntyped kvpValue with | |
| Err error -> Err error | |
| Ok json -> | |
Ok (kvpKey, json) ) | |
|> returnSeqWith ( Map.ofList >> Json.Object ) | |
and map' (x:obj) = | |
let type' = x.GetType() | |
let keyValuePairType = typedefof<System.Tuple<_,_>>.MakeGenericType( type'.GetGenericArguments() ) | |
x :?> System.Collections.IEnumerable |> Seq.cast |> Seq.toList |> List.map ( fun y -> | |
let ty = y.GetType() | |
let kvpKey = ty.GetProperty("Key").GetValue(y, null) | |
let kvpValue = ty.GetProperty("Value").GetValue(y, null) | |
Activator.CreateInstance(keyValuePairType, [|kvpKey; kvpValue|]) | |
|> serializeUntyped ) | |
|> returnSeq | |
|> Result.map Json.Array | |
and array' (x:obj) = | |
[ for y in (x :?> Array) -> serializeUntyped y ] | |
|> returnSeq | |
|> Result.map Json.Array | |
and tuple' (x:obj) = | |
FSharpValue.GetTupleFields x | |
|> Array.toList | |
|> List.map serializeUntyped | |
|> returnSeq | |
|> Result.map Json.Array | |
and option' (x:obj) = | |
let type' = x.GetType() | |
match type'.GetProperty("Value").GetValue(x, null) with | |
| null -> Null () |> Ok | |
| value -> serializeUntyped value | |
and union' (x:obj) = | |
let type' = x.GetType() | |
let case, vals = FSharpValue.GetUnionFields(x, type') | |
if vals |> Array.isEmpty then | |
Json.String case.Name | |
|> Ok | |
else | |
vals | |
|> Array.toList | |
|> List.map serializeUntyped | |
|> returnSeq | |
|> function | |
| Err error -> Err <| sprintf "error serializing discriminated union to json: %A : %A, %s" x (&& type') error | |
| Ok fields -> | |
[ case.Name, Json.Array fields ] | |
|> Map.ofList | |
|> Json.Object | |
|> Ok | |
and record' (x:obj) = | |
let type' = x.GetType() | |
let oks, fails = | |
FSharpType.GetRecordFields(type') | |
|> Array.toList | |
|> List.choose( fun y -> | |
if y.PropertyType = typeof<option<_>> then | |
match FSharpValue.GetRecordField(x,y) with | |
| null -> None | |
| value -> | |
let value = y.PropertyType.GetProperty("Value").GetValue(value, null) | |
Some( y.Name, serializeUntyped value) | |
else | |
(y.Name, FSharpValue.GetRecordField(x,y) |> serializeUntyped ) | |
|> Some ) | |
|> List.partition( snd >> Result.isOk) | |
if fails.IsEmpty then | |
oks | |
|> List.map ( fun (k,v) -> k, Result.Unwrap.ok v) | |
|> Map.ofList | |
|> Json.Object | |
|> Ok | |
else | |
fails | |
|> List.map ( fun (k,v) -> sprintf "%s: %s" k (Result.Unwrap.err v) ) | |
|> Seq.toStr ";\n" id | |
|> sprintf "error serializing record to json: %A : %A, %s" x (&& type') | |
|> Err | |
and trySerializeByKnownType (x : obj) : SerializationResult option = | |
let type' = x.GetType() | |
if isSeq type' then | |
Some <| seq' x | |
elif isStringMap type' then | |
Some <| stringMap' x | |
elif isMap type' then | |
Some <| map' x | |
elif type'.IsArray then | |
Some <| array' x | |
elif FSharpType.IsTuple type' then | |
Some <| tuple' x | |
elif isOption type' then | |
Some <| option' x | |
elif FSharpType.IsUnion type' then | |
Some <| union' x | |
elif FSharpType.IsRecord type' then | |
Some <| record' x | |
else None | |
module private Deserialization = | |
open System.Globalization | |
let str' = function | |
| Json.String x -> x | |
| Number x -> sprintf "%g" x | |
| Null () -> "" | |
| Array _ as x -> stringify x | |
| Object _ as x -> stringify x | |
| Bool x -> sprintf "%b" x | |
let int' integerNumberType = function | |
| Number x -> | |
changeType (Math.Round x) integerNumberType | |
|> Ok | |
| Bool x -> | |
changeType (if x then 1 else 0) integerNumberType | |
|> Ok | |
| String x -> | |
let b,x = Int64.TryParse x | |
if b then changeType x integerNumberType |> Ok else | |
Err <| sprintf "error deserialize JSON, %A is not json integer number value %A" x (&& integerNumberType) | |
| json -> | |
stringify json | |
|> sprintf "error deserialize JSON, not a json integer number value %A : %s" (&& integerNumberType) | |
|> Err | |
let float' floatNumberType = function | |
| Number x -> changeType x floatNumberType |> Ok | |
| Bool x -> changeType (if x then 1 else 0) floatNumberType |> Ok | |
| String x -> | |
let b,x = Decimal.TryParse x | |
if b then changeType x floatNumberType |> Ok else | |
Err <| sprintf "%A is not json float number value %A" x (&& floatNumberType) | |
| json -> | |
stringify json | |
|> sprintf "not a json integer number value %A : %s" (&& floatNumberType) | |
|> Err | |
let bool' = function | |
| Number x -> Ok ( x <> 0m ) | |
| Bool x -> Ok x | |
| String x -> | |
match x.ToLower() with | |
| "true" -> Ok true | |
| "false" -> Ok false | |
| value -> sprintf "error deserialize JSON, not a boolean value %A" value |> Err | |
| json -> | |
stringify json | |
|> sprintf "error deserialize JSON, not a boolean value %A : %s" json | |
|> Err | |
let integerTypes = | |
[ typeof<int8> ; typeof<int16>; typeof<int>; typeof<int64>; | |
typeof<byte>; typeof<uint16>; typeof<uint32> ; typeof<uint64> ] | |
let floatTypes = | |
[ typeof<float> ; typeof<single>; typeof<decimal> ] | |
let (|NumProp|_|) name json = | |
match json with | |
| Prop name (Number value) -> Some value | |
| _ -> None | |
let datetime' = function | |
| NumProp "Year" year & | |
NumProp "Month" month & | |
NumProp "Day" day & | |
NumProp "Hour" hour & | |
NumProp "Minute" minute & | |
NumProp "Second" second & | |
NumProp "Millisecond" millisecond -> | |
DateTime( int year, int month, int day, int hour, int minute, int second, int millisecond) |> box |> Ok | |
| String s -> | |
match DateTime.TryParse(s) with | |
| true, x -> x |> box |> Ok | |
| _ -> sprintf "not date time %A" s |> Err | |
| json -> | |
stringify json | |
|> sprintf "not date time value %s" | |
|> Err | |
let timespan' = function | |
| NumProp "Days" days & | |
NumProp "Hours" hours & | |
NumProp "Minutes" minutes & | |
NumProp "Seconds" seconds & | |
NumProp "Milliseconds" milliseconds -> | |
TimeSpan(int days, int hours, int minutes, int seconds, int milliseconds) |> box |> Ok | |
| json -> | |
stringify json | |
|> sprintf "not time span value %s" | |
|> Err | |
let plain' type' json = | |
if type'= typeof<string> then | |
str' json |> box |> Ok |> Some | |
elif type'= typeof<DateTime> then | |
datetime' json |> Some | |
elif type'= typeof<TimeSpan> then | |
timespan' json |> Some | |
elif List.tryFind ( (=) type') integerTypes |> Option.isSome then | |
int' type' json |> Some | |
elif List.tryFind ( (=) type') floatTypes |> Option.isSome then | |
float' type' json |> Some | |
elif type'=typeof<bool> then | |
bool' json |> Result.map( box ) |> Some | |
elif type'=typeof<unit> then | |
match json with | |
| Null () -> box () |> Ok | |
| _ -> | |
stringify json | |
|> sprintf "error deserialize JSON, not null %A : %s" (&& type') | |
|> Err | |
|> Some | |
else None | |
let returnList' valuetype (xs: _ list) = | |
xs | |
|> List.map ( snd >> Result.Unwrap.ok ) | |
|> makeListOf valuetype | |
|> Ok | |
let returnOfList' type' valuetype (xs: _ list) = | |
Activator.CreateInstance ( type', returnList' valuetype xs) | |
|> Ok | |
let list' (type':Type) deserialize json = | |
let valueType = type'.GetGenericArguments().[0] | |
match json with | |
| Array jsons -> | |
let oks,fails = | |
List.map ( deserialize valueType ) jsons | |
|> List.zip jsons | |
|> List.partition ( snd >> Result.isOk ) | |
if fails.IsEmpty then returnList' valueType oks else | |
fails | |
|> List.map ( fun (json, xleft) -> | |
sprintf "%s: %s" (stringify json) (Result.Unwrap.err xleft) ) | |
|> Seq.toStr ";\n\t" id | |
|> sprintf "error deserializing json to list %A, %s" (&& type') | |
|> Err | |
| _ -> Err <| sprintf "error deserializing json to list %A, %s" (&& type') (stringify json) | |
let stringMap' (type':Type) deserialize json = | |
let valuetype = type'.GetGenericArguments().[1] | |
let keyValuePairType = typedefof<System.Tuple<_,_>>.MakeGenericType( type'.GetGenericArguments() ) | |
match json with | |
| Object jsonProps -> | |
let oks,fails = | |
jsonProps |> Map.toList |> List.map ( fun ( key,jsonValue) -> | |
( key,jsonValue), deserialize valuetype jsonValue ) | |
|> List.partition ( snd >> Result.isOk ) | |
if fails.IsEmpty then | |
let kvs = | |
oks | |
|> List.map ( fun ((key,_),xright) -> | |
Activator.CreateInstance( keyValuePairType, [| box key; Result.Unwrap.ok xright|] ) ) | |
|> makeListOf keyValuePairType | |
Activator.CreateInstance ( type', kvs ) | |
|> Ok | |
else | |
fails | |
|> List.map ( fun ((k,json), xleft) -> | |
sprintf "key %s, %s, %s" k (Result.Unwrap.err xleft) (stringify json) ) | |
|> Seq.toStr ";\n\t" id | |
|> sprintf "error deserializing json to string map %A, %s" (&& type') | |
|> Err | |
| _ -> Err <| sprintf "error deserializing json to string map %A, %s" (&& type') (stringify json) | |
let map' (type':Type) deserialize json = | |
let keyValuePairType = typedefof<System.Tuple<_,_>>.MakeGenericType( type'.GetGenericArguments() ) | |
match json with | |
| Array jsons -> | |
let oks,fails = | |
jsons | |
|> List.map ( fun xjson -> | |
(keyValuePairType, xjson), deserialize keyValuePairType xjson ) | |
|> List.partition ( snd >> Result.isOk ) | |
if fails.IsEmpty then | |
let kvs = | |
oks | |
|> List.map ( snd >> Result.Unwrap.ok ) | |
|> makeListOf keyValuePairType | |
Activator.CreateInstance ( type', kvs ) | |
|> Ok | |
else | |
fails | |
|> List.map ( fun ((k,json), xleft) -> | |
sprintf "key type is %A, %s, %s" k (Result.Unwrap.err xleft) (stringify json) ) | |
|> Seq.toStr ";\n\t" id | |
|> sprintf "error deserializing json to map %A, %s" (&& type') | |
|> Err | |
| _ -> | |
Err <| sprintf "error deserializing json to map %A, %s" (&& type') (stringify json) | |
let set' (type':Type) deserialize json = | |
let valueType = type'.GetGenericArguments().[0] | |
match json with | |
| Array jsons -> | |
let oks,fails = | |
jsons | |
|> List.map ( fun xjson -> xjson, deserialize valueType xjson ) | |
|> List.partition ( snd >> Result.isOk ) | |
if fails.IsEmpty then | |
let kvs = | |
oks | |
|> List.map ( snd >> Result.Unwrap.ok ) | |
Activator.CreateInstance ( type', makeListOf valueType kvs ) | |
|> Ok | |
else | |
fails | |
|> List.map ( fun (json, xleft) -> | |
sprintf "%s, %s" (Result.Unwrap.err xleft) (stringify json) ) | |
|> Seq.toStr ";\n\t" id | |
|> sprintf "error deserializing json to set %A, %s" (&& type') | |
|> Err | |
| _ -> | |
Err <| sprintf "error deserializing json to set %A, %s" (&& type') (stringify json) | |
let array' (type':Type) deserialize json = | |
let valueType = type'.GetElementType() | |
match json with | |
| Array jsons -> | |
let result = Array.CreateInstance( valueType, jsons.Length ) | |
let oks,fails = | |
jsons | |
|> List.mapi ( fun n xjson -> (xjson,n), deserialize valueType xjson ) | |
|> List.partition ( snd >> Result.isOk ) | |
if fails.IsEmpty then | |
oks | |
|> List.iter( fun ((_,n),xright) -> | |
result.SetValue( Result.Unwrap.ok xright, n ) ) | |
box result |> Ok | |
else | |
fails | |
|> List.map ( fun ((json,n), xleft) -> | |
sprintf "[%d] - %s, %s" n (Result.Unwrap.err xleft) (stringify json) ) | |
|> Seq.toStr ";\n" id | |
|> sprintf "error deserializing json to array %A, %s" (&& type') | |
|> Err | |
| _ -> | |
Err <| sprintf "error deserializing json to array %A, %s" (&& type') (stringify json) | |
let tuple' (type':Type) deserialize json = | |
let tes = FSharpType.GetTupleElements(type') | |
match json with | |
| Array src when src.Length >= tes.Length -> | |
let oks,fails = | |
src | |
|> Seq.take tes.Length | |
|> Seq.toArray |> Array.zip tes | |
|> Array.map( fun (te,jsonx) -> (te,jsonx), deserialize te jsonx ) | |
|> Array.partition (snd >> Result.isOk) | |
if Array.isEmpty fails then | |
FSharpValue.MakeTuple( oks |> Array.map ( snd >> Result.Unwrap.ok ), type' ) | |
|> Ok | |
else | |
fails |> Array.map ( fun ((t,json), xleft) -> | |
sprintf "%A : %s, %s" t (Result.Unwrap.err xleft) (stringify json) ) | |
|> Seq.toStr ";\n\t" id | |
|> sprintf "error deserializing json to tuple %A, %s" (&& type') | |
|> Err | |
| _ -> | |
Err <| sprintf "error deserializing json to tuple %A, %s" (&& type') (stringify json) | |
let option' (type':Type) deserialize json = | |
let cases = FSharpType.GetUnionCases type' |> Array.toList | |
match json with | |
| Null () -> FSharpValue.MakeUnion(cases.[0], [||]) |> Ok | |
| _ -> | |
deserialize (type'.GetGenericArguments().[0]) json | |
|> Result.map( fun x -> | |
FSharpValue.MakeUnion(cases.[1], [|x|]) ) | |
let (|GetCase|_|) cases x = | |
match cases |> List.tryFind( fun (case : UnionCaseInfo) -> case.Name=x) with | |
| Some case -> Some(case, case.GetFields() |> Array.toList ) | |
| _ -> None | |
let (|MapToList|) = Map.toList | |
let union' (type':Type) deserialize json = | |
let cases = FSharpType.GetUnionCases type' |> Array.toList | |
match json with | |
| String ( GetCase cases (case,fields) ) when fields.IsEmpty -> | |
FSharpValue.MakeUnion(case, [||]) |> Ok | |
| Object ( MapToList [ GetCase cases (case,fields), Array jsons] ) when fields.Length = jsons.Length -> | |
let oks,fails = | |
jsons |> List.zip fields | |
|> List.map( fun ((field,xjson) as k) -> | |
k, deserialize field.PropertyType xjson ) | |
|> List.partition (snd >> Result.isOk) | |
if fails.IsEmpty then | |
let xs = oks |> List.map( snd >> Result.Unwrap.ok ) |> List.toArray | |
FSharpValue.MakeUnion(case, xs) | |
|> Ok | |
else | |
fails |> List.map ( fun ((p,json), xerr) -> | |
sprintf | |
"union case %A : %A - %s, %s" | |
p.Name p.PropertyType | |
(Result.Unwrap.err xerr) | |
(stringify json) ) | |
|> Seq.toStr ";\n\t" id | |
|> sprintf "error deserializing json to union %A, %s" (&& type') | |
|> Err | |
| _ -> | |
Err <| sprintf "error deserializing json to union %A, %s" (&& type') (stringify json) | |
let recordFieldNone' (type':Type) = | |
let gtype' = type'.GetGenericTypeDefinition() | |
if gtype' = typedefof<option<_>> then | |
let case = (FSharpType.GetUnionCases type').[0] | |
let value = FSharpValue.MakeUnion(case, [||]) | |
Some value | |
elif gtype' = typedefof<Map<_,_>> then | |
let keyValuePairType = typedefof<System.Tuple<_,_>>.MakeGenericType( type'.GetGenericArguments() ) | |
let value = Activator.CreateInstance( type', makeListOf keyValuePairType [] ) | |
Some value | |
elif gtype' = typedefof<list<_>> then | |
let valueType = type'.GetGenericArguments().[0] | |
let value = makeListOf valueType [] | |
Some value | |
else None | |
let recordField' jprops deserialize (prop : PropertyInfo) = | |
let propType = prop.PropertyType | |
match Map.tryFind prop.Name jprops with | |
| None when propType.IsGenericType -> | |
match recordFieldNone' propType with | |
| Some x -> Ok x | |
| _ -> sprintf "missing value of property %A" prop.Name |> Err | |
| None -> sprintf "missing value of property %A" prop.Name |> Err | |
| Some xjson -> | |
deserialize propType xjson | |
|> Result.mapErr( fun error -> sprintf "%s - %s, %s" prop.Name error (stringify xjson) ) | |
let record' (type':Type) deserialize json = | |
match json with | |
| Object jprops -> | |
let oks,fails = | |
FSharpType.GetRecordFields(type') |> Array.map (recordField' jprops deserialize) | |
|> Array.partition Result.isOk | |
if Array.isEmpty fails then | |
FSharpValue.MakeRecord( type', oks |> Array.map Result.Unwrap.ok ) | |
|> Ok | |
else | |
fails | |
|> Array.map Result.Unwrap.err | |
|> Seq.toStr ";\n\t" id | |
|> sprintf "error deserializing json to record %A, %s" (&& type') | |
|> Err | |
| _ -> | |
Err <| sprintf "error deserializing json to record %A, %s" (&& type') (stringify json) | |
let deserializerFor' (t:Type) = | |
if isList t then Some list' | |
elif isStringMap t then Some stringMap' | |
elif isMap t then Some map' | |
elif isSet t then Some set' | |
elif t.IsArray then Some array' | |
elif FSharpType.IsTuple t then Some tuple' | |
elif isOption t then Some option' | |
elif FSharpType.IsUnion t then Some union' | |
elif FSharpType.IsRecord t then Some record' | |
else None | |
let rec deserializeUntyped (type':Type) (json : Json) : Result<obj,string> = | |
match tryDeserializeCustomFromJson type' json with | |
| Some x -> x | |
| _ -> | |
match plain' type' json with | |
| Some x -> x | |
| _ -> | |
match deserializerFor' type' with | |
| None -> failwithf "can't find json deserializer for %A" (&& type') | |
| Some deserialize' -> | |
deserialize' type' deserializeUntyped json | |
and tryDeserializeCustomFromJson(type':Type) (json:Json) = | |
let fromJson = | |
type'.GetMethod | |
( "FromJsonUntyped", | |
BindingFlags.Public ||| BindingFlags.Static, | |
null, | |
CallingConventions.Any, | |
[| typeof<Json> |], | |
null ) | |
let rtype' = typeof<Result<obj,string>> | |
if fromJson <> null then | |
if fromJson.ReturnType <> rtype' then | |
failwithf "return type of %A.FromJsonUntyped must be %A, but is %A" | |
type'.Name rtype'.Name fromJson.ReturnType.Name | |
try | |
fromJson.Invoke(null, [|json|] ) :?> Result<obj,string> | |
with e -> | |
Err <| sprintf "error calling %A.FromJsonUntyped on %A : %A" type'.Name (stringify json) e.Message | |
|> Some | |
else None | |
let serializeUntyped = Serialization.serializeUntyped | |
let serialize<'a> (x:'a) = | |
match serializeUntyped x with | |
| Err e -> failwithf "error serialize JSON %A : %A - %s" x (&& x.GetType()) e | |
| Ok x -> x | |
let deserializeUntyped = Deserialization.deserializeUntyped | |
let deserialize<'T> json = | |
deserializeUntyped typeof<'T> json | |
|> Result.map( fun x -> x :?> 'T) | |
let parse<'T> = | |
Json.parse | |
>> Result.mapErr ( sprintf "can't parse %A - %s" (&& typeof<'T>) ) | |
>> Result.bind( | |
deserialize<'T> | |
>> Result.mapErr ( sprintf "can't deserialize %A - %s" (&& typeof<'T>) ) ) | |
let stringify<'a> = serialize<'a> >> stringify |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment