F# FSharp.Data.JsonValue codec syntax

JsonValueCodecSyntax.fs

/// port of https://github.com/mausch/Fleece

type ToJsonClass = ToJsonClass

type FromJsonClass = FromJsonClass

type ParseResult<'a> = Choice<'a, string>

module ParseResult =
    
    let inline unit a : ParseResult<'a> = Choice1Of2 a

    let inline error err : ParseResult<'a> = Choice2Of2 err

    let get<'a> (r:ParseResult<'a>) : 'a = 
        match r with
        | Success r -> r
        | Failure err -> failwith (sprintf "parse failed=%s" err)

    let tryGetOpt<'a> (r:ParseResult<'a option>) : 'a option = 
        match r with
        | Success r -> r
        | _ -> None

    let map f (r:ParseResult<'a>) : ParseResult<'b> = 
        match r with
        | Success a -> unit (f a)
        | Failure err -> error err
    
    let bind f (r:ParseResult<'a>) : ParseResult<'b> =
        match r with
        | Success a -> f a
        | Failure err -> error err
    
    let traverseA (f:'a -> ParseResult<'b>) (xs:'a[]) : ParseResult<'b[]> =
        let length = Array.length xs
        let acc : 'b[] = Array.zeroCreate length
        let rec go i = 
            if i = length then null
            else
                match f xs.[i] with
                | Success a -> 
                    acc.[i] <- a
                    go (i + 1)
                | Failure err -> err
        let err = go 0
        if err = null then unit acc
        else error err        
        
    type JsonParserBuilder() =
        member x.Return a = unit a
        member x.ReturnFrom r = r
        member x.Bind (inp:ParseResult<'a>, body:'a -> ParseResult<'b>) : ParseResult<'b> = bind body inp
    


[<AutoOpen>]
module Helpers =

    let jsonParse = new ParseResult.JsonParserBuilder()

    
    let inline toJson_ (a: ^a, b: ^b) = ((^a or ^b) : (static member ToJson: ^b -> JsonValue) b)

    /// Encodes a value of a type containing a ToJson function into a JsonValue.
    let inline toJson x : JsonValue = toJson_ (ToJsonClass, x)    

    /// Encodes a value into a JSON string.
    let inline toJsonString x : string = x |> toJson |> JsonValue.toString

    /// Encodes a value into a JSON byte array.
    let inline toJsonBytes x : byte[] = x |> toJson |> JsonValue.toString |> Encoding.UTF8.GetBytes
        
    /// Creates a JSON property.
    let inline jprop (name:string) (x:'a) = (name,toJson x)
    
    /// Creates a JSON object.
    let inline jobj (props:(string * JsonValue)[]) = props |> JsonValue.Record

    
    /// Creates a successful ParseResult.
    let succeed x = ParseResult.unit x

    /// Creates a failed ParseResult.
    let fail err = ParseResult.error err


    let inline private fromJson_ (a:^a, b:^b) = ((^a or ^b) : (static member FromJson:^b -> (JsonValue -> ^b ParseResult)) b)

    /// Parses a JsonValue into a specified type containing a FromJson function.
    let inline fromJson (json:JsonValue) = fromJson_ (FromJsonClass, Unchecked.defaultof<'a>) json

    /// Parse a JsonValue into a specified type and applies a mapping.
    let inline fromJsonTo (json:JsonValue) (f:'a -> 'b) = fromJson json |> ParseResult.map f

    /// Parses a JSON string.
    let inline parseJson (json:string) = JsonValue.Parse json |> fromJson

    /// Parses a byte array.
    let inline parseJsonBytes (json:byte[]) = Encoding.UTF8.GetString(json) |> JsonValue.Parse |> fromJson

    /// Parses a JSON property into a specified type.
    let inline jget (json:JsonValue) key = 
        let prop = json.TryGetProperty key
        match prop with
        | Some prop -> fromJson prop
        | None -> fail (sprintf "can't find key '%s'" key)

    /// Optionally parses a JSON property into a specified type.
    let inline jgetopt (json:JsonValue) key = 
        let prop = json.TryGetProperty key
        match prop with
        | Some prop -> fromJson prop |> ParseResult.map Some
        | None -> succeed None

    let parseObj (f:JsonValue -> ParseResult<'a>) (json:JsonValue) : ParseResult<'a> =
        match json with
        | JsonValue.Record _ as json -> f json
        | _ -> fail "JSON object expected."




type ToJsonClass with

    static member inline ToJson (x:JsonValue) = x
    static member inline ToJson (x:(string * JsonValue)[]) = JsonValue.Record x
    static member inline ToJson (x:int) = JsonValue.Number (decimal x)
    static member inline ToJson (x:int64) = JsonValue.Number (decimal x)
    static member inline ToJson (x:int16) = JsonValue.Number (decimal x)
    static member inline ToJson (x:bool) = JsonValue.Boolean x
    static member inline ToJson (x:float) = JsonValue.Float x
    static member inline ToJson (x:single) = JsonValue.Float (float x)
    static member inline ToJson (x:char) = JsonValue.String (x.ToString())
    static member inline ToJson (x:decimal) = JsonValue.Number x
    static member inline ToJson (x:string) = if x = null then JsonValue.Null else JsonValue.String x
    static member inline ToJson (x:DateTime) = JsonValue.String (x.ToString("yyyy-MM-ddTHH:mm:ssZ"))
    static member inline ToJson (x:DateTimeOffset) = JsonValue.String (x.ToString("yyyy-MM-ddTHH:mm:ssK"))    

    static member inline ToJson (x:'a array) = x |> Array.map toJson |> JsonValue.Array
    //static member inline ToJson (x:System.Collections.Generic.IEnumerable<'a>) = x |> Seq.toArray |> ToJsonClass.ToJson    
    static member inline ToJson (x:'a list) = x |> List.toArray |> ToJsonClass.ToJson    
    static member inline ToJson (x:'a Set) = x |> Set.toArray |> ToJsonClass.ToJson
    static member inline ToJson (x:Map<string, 'a>) = x |> Map.map (fun _ v -> toJson v) |> Map.toArray |> jobj
    static member inline ToJson (x:'a option) = match x with Some x -> toJson x | None -> JsonValue.Null

    static member inline ToJson (x:Choice<_,_>) = 
        match x with
        | Choice1Of2 a -> jobj [| "left"  .= a |]
        | Choice2Of2 b -> jobj [| "right" .= b |]




type FromJsonClass with
    
    static member FromJson (_:string) = function
        | JsonValue.String s -> succeed s
        | JsonValue.Null -> succeed null
        | _ -> fail "string"

    static member FromJson (_:int) = function
        | JsonValue.Number _ as j -> j.AsInteger() |> succeed
        | JsonValue.Float _ as j -> j.AsInteger() |> succeed
        | _ -> fail "int"

    static member FromJson (_:decimal) = function
        | JsonValue.Number _ as j -> j.AsDecimal() |> succeed
        | JsonValue.Float _ as j -> j.AsDecimal() |> succeed
        | _ -> fail "decimal"

    static member FromJson (_:float) = function
        | JsonValue.Number _ as j -> j.AsFloat() |> succeed
        | JsonValue.Float _ as j -> j.AsFloat() |> succeed
        | _ -> fail "float"

    static member FromJson (_:bool) = function
        | JsonValue.Boolean b -> b |> succeed
        | _ -> fail "bool"

    static member FromJson (_:DateTime) = function
        | JsonValue.String s ->
            match DateTime.TryParseExact(s, "yyyy-MM-ddTHH:mm:ssZ", null, DateTimeStyles.RoundtripKind) with
            | true,dt -> succeed dt
            | _ -> fail "datetime"
        | _ -> fail "datetime"       
    
    static member FromJson (_:DateTimeOffset) = function
        | JsonValue.String s ->
            match DateTimeOffset.TryParseExact(s, "yyyy-MM-ddTHH:mm:ssK", null, DateTimeStyles.RoundtripKind) with
            | true,dt -> succeed dt
            | _ -> fail "datetime"
        | _ -> fail "datetime"
    
    static member inline FromJson (_:'a option) = function
        | JsonValue.Null -> succeed None
        | json -> 
            let a : ParseResult<'a> = fromJson json
            a |> ParseResult.map Some

    static member inline FromJson (_:'a[]) = function
        | JsonValue.Array xs ->            
            let xs : ParseResult<'a[]> = xs |> ParseResult.traverseA fromJson
            xs
        | _ -> fail "array"

    static member inline FromJson (_:list<'a>) = function
        | JsonValue.Array xs ->            
            let xs : ParseResult<'a[]> = xs |> ParseResult.traverseA fromJson
            xs |> ParseResult.map List.ofArray
        | _ -> fail "list"

    static member inline FromJson (_:Set<'a>) = function
        | JsonValue.Array xs ->            
            let xs : ParseResult<'a[]> = xs |> ParseResult.traverseA fromJson
            xs |> ParseResult.map Set.ofArray
        | _ -> fail "list"

    static member inline FromJson (_:Choice<'a, 'b>) = function
        | JsonValue.Record [| "left"  , json |] -> let r : ParseResult<'a> = json |> fromJson in r |> ParseResult.map Choice1Of2
        | JsonValue.Record [| "right" , json |] -> let r : ParseResult<'b> = json |> fromJson in r |> ParseResult.map Choice2Of2
        | _ -> fail "choice"

[<AutoOpen>]
module Ops =
    
    /// Creates a JSON property given a key (property name) and corresponding value.
    let inline (.=) key value = jprop key value

    /// Parses a property from a JSON value.
    let inline (.@) json key = jget json key
    
    /// Parses a property from a JSON value, which may be absent.
    let inline (.@?) json key = jgetopt json key