Json in F#

Json.fs

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

JsonSerialization.fs

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