Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
F# FSharp.Data.JsonValue codec syntax
/// 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