F# FSharp.Data.JsonValue codec syntax
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
| /// 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment