Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
2004 lines (1651 sloc) 86.9 KB
namespace Chiron
type JsonMemberType =
| Object
| Array
| String
| Number
| Bool
| Null
type [<StructuralEquality;NoComparison>] Json =
| Object of properties: JsonObject
| Array of elements: Json list
| String of string
| Number of number:string
| True
| False
| Null
and [<CustomEquality;NoComparison>] JsonObject =
| WriteObject of propList: (string * Json) list
| ReadObject of propList: (string * Json) list * propMap: Map<string,Json>
override x.Equals(o) =
match o with
| :? JsonObject as y -> (x :> System.IEquatable<JsonObject>).Equals(y)
| _ -> false
override x.GetHashCode() =
match x with
| WriteObject ps -> Map.ofList (List.rev ps) |> hash
| ReadObject (_, mps) -> mps |> hash
interface System.IEquatable<JsonObject> with
member x.Equals(y) =
match x, y with
| WriteObject xps, WriteObject yps -> Map.ofList (List.rev xps) = Map.ofList (List.rev yps)
| ReadObject (_, mps), WriteObject ps -> Map.ofList (List.rev ps) = mps
| WriteObject ps, ReadObject (_, mps) -> Map.ofList (List.rev ps) = mps
| ReadObject (_, xps), ReadObject (_, yps) -> xps = yps
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JsonMemberType =
let ofJson = function
| Json.Object _ -> JsonMemberType.Object
| Json.Array _ -> JsonMemberType.Array
| Json.String _ -> JsonMemberType.String
| Json.Number _ -> JsonMemberType.Number
| Json.True -> JsonMemberType.Bool
| Json.False -> JsonMemberType.Bool
| Json.Null -> JsonMemberType.Null
let describe = function
| JsonMemberType.Object -> "an object"
| JsonMemberType.Array -> "an array"
| JsonMemberType.String -> "a string"
| JsonMemberType.Number -> "a number"
| JsonMemberType.Bool -> "a boolean"
| JsonMemberType.Null -> "null"
type JsonFailureTag =
| PropertyTag of propertyName: string
| IndexTag of index: uint32
| ChoiceTag of choice: uint32
type JsonFailureReason =
| OtherError of err: exn
| PropertyNotFound of name: string
| TypeMismatch of expected: JsonMemberType * actual: JsonMemberType
| DeserializationError of targetType: System.Type * err: exn
| InvalidJson of err: string
| NoInput
type JsonFailure =
| Tagged of tag: JsonFailureTag * jFail: JsonFailure
| SingleFailure of jFail: JsonFailureReason
| PairedFailures of leftFail: JsonFailure * rightFail: JsonFailure
| MultipleFailures of jFails: JsonFailure list
type ChironErrorPolicy =
| StopOnFirstError
| ContinueOnError
type JsonResult<'a> =
| JPass of 'a
| JFail of JsonFailure
[<RequireQualifiedAccess>]
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JsonFailureTag =
let toString = function
| PropertyTag p -> p
| IndexTag i -> System.String.Concat ("[", string i, "]")
| ChoiceTag c -> System.String.Concat ("(Choice #", string (c + 1u), ")")
let toTagPathString prefixO tag =
match prefixO, tag with
| Some prefix, PropertyTag p -> System.String.Concat (prefix, ".", p)
| Some prefix, IndexTag i -> System.String.Concat (prefix, "[", string i, "]")
| Some prefix, ChoiceTag c -> System.String.Concat (prefix, "(Choice #", string (c + 1u), ")")
| None, _ -> toString tag
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JsonFailureReason =
let toString = function
| OtherError e -> string e
| PropertyNotFound k -> "Failed to find expected property: " + k
| TypeMismatch (e,a) -> System.String.Concat ("Expected to find ", JsonMemberType.describe e, ", but instead found ", JsonMemberType.describe a)
| DeserializationError (t,e) -> System.String.Concat ("Unable to deserialize value as '", t.FullName, "': ", string e)
| InvalidJson e -> "Invalid JSON, failed to parse: " + e
| NoInput -> "No input was provided"
let toStringWithPath pathO jFail =
let path = (match pathO with Some p -> p; | _ -> System.String.Empty)// |> Option.defaultValue System.String.Empty
System.String.Concat (path, ": ", toString jFail)
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JsonFailure =
let mappend jFail1 jFail2 =
PairedFailures (jFail1, jFail2)
let tag (t: JsonFailureTag) (f: JsonFailure) =
Tagged (t, f)
let toStrings jFail =
let rec inner (prefix: string option) = function
| Tagged (tag, innerFail) ->
inner (JsonFailureTag.toTagPathString prefix tag |> Some) innerFail
| SingleFailure jfr ->
[ JsonFailureReason.toStringWithPath prefix jfr ]
| PairedFailures (jFail1, jFail2) ->
[ jFail1; jFail2 ] |> List.collect (inner prefix)
| MultipleFailures jFails ->
jFails |> List.rev |> List.collect (inner prefix)
inner None jFail
let summarize jFail =
match toStrings jFail with
| [] -> "No errors"
| [e] -> sprintf "Found 1 error:\n %s" <| e
| errs ->
let sb = System.Text.StringBuilder()
sb.AppendLine(sprintf "Found %i errors:" (List.length errs)) |> ignore
errs |> List.iter (fun e -> sb.Append(" ").AppendLine(e) |> ignore)
sb.ToString()
module JsonResult =
let inline pass a = JPass a
let inline fail f = JFail f
let inline fails fs = JFail (MultipleFailures fs)
let getOrThrow : JsonResult<'a> -> 'a = function
| JPass x -> x
| JFail f -> failwith (JsonFailure.toStrings f |> String.concat "\n")
let toResult : JsonResult<'a> -> Result<'a, JsonFailure> = function
| JPass x -> Ok x
| JFail f -> Error f
let raise e = fail (SingleFailure (OtherError e))
let typeMismatch expected json = fail (SingleFailure (TypeMismatch (expected, JsonMemberType.ofJson json)))
let deserializationError<'a> exn : JsonResult<'a> = fail (SingleFailure (DeserializationError (typeof<'a>, exn)))
let invalidJson err : JsonResult<'a> = fail (SingleFailure (InvalidJson err))
let noInput<'a> : JsonResult<'a> = fail (SingleFailure NoInput)
let propertyNotFound f : JsonResult<'a> = fail (SingleFailure (PropertyNotFound f))
let failWithTag t f : JsonResult<'a> = fail (Tagged (t, f))
let inline bind (a2bR: 'a -> JsonResult<'b>) (aR : JsonResult<'a>) : JsonResult<'b> =
match aR with
| JPass a -> a2bR a
| JFail x -> fail x
let inline map (a2b: 'a -> 'b) (aR : JsonResult<'a>) : JsonResult<'b> =
match aR with
| JPass a -> pass (a2b a)
| JFail x -> fail x
let inline apply (aR: JsonResult<'a>) (a2Rb: JsonResult<'a -> 'b>) : JsonResult<'b> =
match a2Rb, aR with
| JPass a2b, JPass a -> pass (a2b a)
| JFail e1, JFail e2 -> fail (JsonFailure.mappend e1 e2)
| JFail e, _ | _, JFail e -> fail e
let applyDelayedWithPolicy (policy: ChironErrorPolicy) (c2aR: 'c -> JsonResult<'a>) (c: 'c) (a2Rb: JsonResult<'a -> 'b>) : JsonResult<'b> =
match a2Rb with
| JPass a2b ->
match c2aR c with
| JPass a -> pass (a2b a)
| JFail e -> fail e
| JFail e1 ->
match policy with
| StopOnFirstError -> fail e1
| ContinueOnError ->
match c2aR c with
| JPass a -> fail e1
| JFail e2 -> fail (JsonFailure.mappend e1 e2)
let applyDelayedWithPolicyAlt (policy: ChironErrorPolicy) : ('c -> JsonResult<'a>) -> 'c -> JsonResult<'a -> 'b> -> JsonResult<'b> =
match policy with
| StopOnFirstError ->
fun c2aR c a2Rb ->
match a2Rb with
| JPass a2b ->
match c2aR c with
| JPass a -> pass (a2b a)
| JFail e -> fail e
| JFail e1 -> fail e1
| ContinueOnError ->
fun c2aR c a2Rb -> apply (c2aR c) a2Rb
type Decoder<'s,'a> = 's -> JsonResult<'a>
type ObjectReader<'a> = Decoder<JsonObject,'a>
type ObjectBuilder<'a> = 'a -> JsonObject -> JsonObject
type JsonDecoder<'a> = Decoder<Json,'a>
type JsonEncoder<'a> = 'a -> Json
module Decoder =
let alwaysPass (a: 'a) : Decoder<'s,'a> =
fun s -> JsonResult.pass a
let alwaysFail (e: JsonFailure) : Decoder<'s,'a> =
fun s -> JsonResult.fail e
let always result : Decoder<'s,'a> =
fun s -> result
let inline bind (a2s2bR: 'a -> Decoder<'s,'b>) (s2aR: Decoder<'s,'a>): Decoder<'s,'b> =
fun s ->
s2aR s
|> JsonResult.bind (fun a -> a2s2bR a s)
let inline map (a2b: 'a -> 'b) (s2aR: Decoder<'s,'a>) : Decoder<'s,'b> =
fun s ->
s2aR s
|> JsonResult.map a2b
let inline compose (b2cR: Decoder<'b,'c>) (a2bR: Decoder<'a,'b>) : Decoder<'a,'c> =
fun a ->
a2bR a
|> JsonResult.bind b2cR
let inline applyWithContinueOnError (s2aR: Decoder<'s,'a>) (s2Ra2b: Decoder<'s,'a -> 'b>) : Decoder<'s,'b> =
fun s ->
match s2Ra2b s, s2aR s with
| JPass a2b, JPass a -> JsonResult.pass (a2b a)
| JFail e1, JFail e2 -> JsonResult.fail (JsonFailure.mappend e1 e2)
| JFail e, _ | _, JFail e -> JsonResult.fail e
let inline applyWithStopOnFirstError (s2aR: Decoder<'s,'a>) (s2Ra2b: Decoder<'s,'a -> 'b>) : Decoder<'s,'b> =
fun s ->
match s2Ra2b s with
| JPass a2b -> s2aR s |> JsonResult.map a2b
| JFail e -> JsonResult.fail e
let applyWithPolicy (policy: ChironErrorPolicy) : Decoder<'s,'a> -> Decoder<'s,'a -> 'b> -> Decoder<'s,'b> =
match policy with
| StopOnFirstError -> applyWithStopOnFirstError
| ContinueOnError -> applyWithContinueOnError
let inline apply (s2aR: Decoder<'s,'a>) (s2Ra2b: Decoder<'s,'a -> 'b>) : Decoder<'s,'b> =
applyWithContinueOnError s2aR s2Ra2b
let map2 (a2b2c: 'a -> 'b -> 'c) (s2aR: Decoder<'s,'a>) (s2bR: Decoder<'s,'b>) : Decoder<'s,'c> =
map a2b2c s2aR
|> apply s2bR
let map3 (a2b2c2d: 'a -> 'b -> 'c -> 'd) (s2aR: Decoder<'s,'a>) (s2bR: Decoder<'s,'b>) (s2cR: Decoder<'s,'c>) : Decoder<'s,'d> =
map a2b2c2d s2aR
|> apply s2bR
|> apply s2cR
let map4 (a2b2c2d2x: 'a -> 'b -> 'c -> 'd -> 'x) (s2aR: Decoder<'s,'a>) (s2bR: Decoder<'s,'b>) (s2cR: Decoder<'s,'c>) (s2dR: Decoder<'s,'d>) : Decoder<'s,'x> =
map a2b2c2d2x s2aR
|> apply s2bR
|> apply s2cR
|> apply s2dR
let map5 (a2b2c2d2x2y: 'a -> 'b -> 'c -> 'd -> 'x -> 'y) (s2aR: Decoder<'s,'a>) (s2bR: Decoder<'s,'b>) (s2cR: Decoder<'s,'c>) (s2dR: Decoder<'s,'d>) (s2xR: Decoder<'s,'x>) : Decoder<'s,'y> =
map a2b2c2d2x2y s2aR
|> apply s2bR
|> apply s2cR
|> apply s2dR
|> apply s2xR
let map6 (a2b2c2d2x2y2z: 'a -> 'b -> 'c -> 'd -> 'x -> 'y -> 'z) (s2aR: Decoder<'s,'a>) (s2bR: Decoder<'s,'b>) (s2cR: Decoder<'s,'c>) (s2dR: Decoder<'s,'d>) (s2xR: Decoder<'s,'x>) (s2yR: Decoder<'s,'y>) : Decoder<'s,'z> =
map a2b2c2d2x2y2z s2aR
|> apply s2bR
|> apply s2cR
|> apply s2dR
|> apply s2xR
|> apply s2yR
let withPropertyTag p (s2aR : Decoder<'s,'a>) : Decoder<'s,'a> =
fun s ->
match s2aR s with
| JPass a -> JsonResult.pass a
| JFail f -> JsonResult.failWithTag (PropertyTag p) f
let withIndexTag i (s2aR : Decoder<'s,'a>) : Decoder<'s,'a> =
fun s ->
match s2aR s with
| JPass a -> JsonResult.pass a
| JFail f -> JsonResult.failWithTag (IndexTag i) f
let withChoiceTag c (s2aR : Decoder<'s,'a>) : Decoder<'s,'a> =
fun s ->
match s2aR s with
| JPass a -> JsonResult.pass a
| JFail f -> JsonResult.failWithTag (ChoiceTag c) f
let inline fromThrowingConverter (convert: 's -> 'a) : Decoder<'s,'a> =
fun s ->
try
JsonResult.pass (convert s)
with e -> JsonResult.deserializationError<'a> e
let inline withPropertyTagInline p (s2aR : Decoder<'s,'a>) : Decoder<'s,'a> =
fun s ->
match s2aR s with
| JPass a -> JsonResult.pass a
| JFail f -> JsonResult.failWithTag (PropertyTag p) f
let inline withIndexTagInline i (s2aR : Decoder<'s,'a>) : Decoder<'s,'a> =
fun s ->
match s2aR s with
| JPass a -> JsonResult.pass a
| JFail f -> JsonResult.failWithTag (IndexTag i) f
let inline withChoiceTagInline c (s2aR : Decoder<'s,'a>) : Decoder<'s,'a> =
fun s ->
match s2aR s with
| JPass a -> JsonResult.pass a
| JFail f -> JsonResult.failWithTag (ChoiceTag c) f
let inline fromThrowingConverterInline (convert: 's -> 'a) : Decoder<'s,'a> =
fun s ->
try
JsonResult.pass (convert s)
with e -> JsonResult.deserializationError<'a> e
module Operators =
let inline (<!>) (a2b: 'a -> 'b) (s2aR: Decoder<'s,'a>) = Decoder.map a2b s2aR
let inline (<*>) (s2Ra2b: Decoder<'s,'a -> 'b>) (s2aR: Decoder<'s,'a>) = Decoder.apply s2aR s2Ra2b
let inline (>=>) (a2bR: Decoder<'a,'b>) (b2cR: Decoder<'b,'c>) = Decoder.compose b2cR a2bR
let inline (>->) (s2aR: Decoder<'s,'a>) (a2b: 'a -> 'b) = Decoder.map a2b s2aR
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JsonObject =
let empty = WriteObject []
module PropertyList =
let inline add k v ps = (k, v) :: ps
let remove k ps = List.filter (fun kvp -> fst kvp <> k) ps
let upsert k v ps =
let mutable found = false
let newList = List.map (fun kvp -> if fst kvp = k then found <- true; (fst kvp, v) else kvp) ps
if not found then
add k v ps
else
newList
let tryFind k ps = List.tryPick (fun kvp -> if fst kvp = k then Some (snd kvp) else None) ps
module PropertyMap =
let inline add k v ps = Map.add k v ps
let inline remove k ps = Map.remove k ps
let inline upsert k v ps = Map.add k v ps
let inline tryFind k ps = Map.tryFind k ps
let add k v = function
| WriteObject ps -> WriteObject (PropertyList.add k v ps)
| ReadObject (ps, mps) ->
ReadObject (PropertyList.add k v ps, PropertyMap.add k v mps)
let remove k = function
| WriteObject ps -> WriteObject (PropertyList.remove k ps)
| ReadObject (ps, mps) -> ReadObject (PropertyList.remove k ps, PropertyMap.remove k mps)
let upsert k v = function
| WriteObject ps -> WriteObject (PropertyList.upsert k v ps)
| ReadObject (ps, mps) ->
ReadObject (PropertyList.upsert k v ps, PropertyMap.upsert k v mps)
let tryFind k = function
| WriteObject ps -> PropertyList.tryFind k ps
| ReadObject (_, mps) -> PropertyMap.tryFind k mps
let find k jsonObj =
match tryFind k jsonObj with
| Some v -> JsonResult.pass v
| None -> JsonResult.propertyNotFound k
let optimizeRead = function
| WriteObject ps -> ReadObject (ps, Map.ofList (List.rev ps))
| o -> o
let optimizeAppend = function
| ReadObject (ps, mps) -> WriteObject ps
| o -> o
let mapToList mps = Map.toList mps |> List.rev
let listToMap ps = List.rev ps |> Map.ofList
let dedupeWithMap kvps m =
if List.length kvps = Map.count m then
kvps
else
let hs = System.Collections.Generic.HashSet ()
List.foldBack (fun (k,_) s -> if hs.Add(k) then (k, Map.find k m) :: s else s) kvps []
let dedupeList kvps =
dedupeWithMap kvps (listToMap kvps)
let removeDuplicates = function
| WriteObject ps -> WriteObject (dedupeList ps)
| ReadObject (ps, mps) ->
if List.length ps <> Map.count mps then
ReadObject (dedupeWithMap ps mps, mps)
else
ReadObject (ps, mps)
let toPropertyListWithCustomKeyQuick (parse: Decoder<string,'a>) (decode: Decoder<Json,'b>) : Decoder<JsonObject,('a * 'b) list> = function
| WriteObject ps
| ReadObject (ps, _) ->
let rec loop agg lastK lastV ps =
match Decoder.withPropertyTag lastK parse lastK with
| JPass k ->
match Decoder.withPropertyTag lastK decode lastV with
| JPass v ->
let nextAgg = (k,v)::agg
match ps with
| [] -> JsonResult.pass nextAgg
| (nextK,nextV)::nextPs -> loop nextAgg nextK nextV nextPs
| JFail errs -> JsonResult.fail errs
| JFail errs -> JsonResult.fail errs
match ps with
| [] -> JsonResult.pass []
| (initK,initV)::initPs -> loop [] initK initV initPs
let toPropertyListWithCustomKey (parse: Decoder<string,'a>) (decode: Decoder<Json,'b>) : Decoder<JsonObject,('a * 'b) list> =
let idλ = (do ()); fun (x: JsonFailure list) -> x
function
| WriteObject ps
| ReadObject (ps, _) ->
let rec goodPath agg lastK lastV ps =
let kR = Decoder.withPropertyTag lastK parse lastK
let vR = Decoder.withPropertyTag lastK decode lastV
match kR, vR with
| JPass k, JPass v ->
let nextAgg = (k,v)::agg
match ps with
| [] -> JsonResult.pass nextAgg
| (nextK,nextV)::nextPs -> goodPath nextAgg nextK nextV nextPs
| JFail errs1, JFail errs2 ->
badPathTransfer [errs2;errs1] ps
| JFail errs, _
| _, JFail errs ->
badPathTransfer [errs] ps
and badPath (aggErrs: JsonFailure list) lastK lastV ps =
let kR = Decoder.withPropertyTag lastK parse lastK
let vR = Decoder.withPropertyTag lastK decode lastV
match kR, vR with
| JFail errs1, JFail errs2 ->
badPathTransfer (errs2::errs1::aggErrs) ps
| JFail errs, _
| _, JFail errs ->
badPathTransfer (errs::aggErrs) ps
| _ ->
badPathTransfer aggErrs ps
and badPathTransfer aggErrs ps =
match ps with
| [] -> JsonResult.fails aggErrs
| (nextK,nextV)::nextPs -> badPath aggErrs nextK nextV nextPs
match ps with
| [] -> JPass []
| (initK,initV)::initPs -> goodPath [] initK initV initPs
let toPropertyListWithQuick (decode: Decoder<Json,'b>) = function
| WriteObject ps
| ReadObject (ps, _) ->
let rec loop agg k lastV ps =
match Decoder.withPropertyTag k decode lastV with
| JPass v ->
let nextAgg = (k,v)::agg
match ps with
| [] -> JsonResult.pass nextAgg
| (nextK,nextV)::nextPs -> loop nextAgg nextK nextV nextPs
| JFail errs -> JsonResult.fail errs
match ps with
| [] -> JsonResult.pass []
| (initK,initV)::initPs -> loop [] initK initV initPs
let toPropertyListWith (decode: Decoder<Json,'b>) =
let idλ = (do ()); fun (x: JsonFailure list) -> x
function
| WriteObject ps
| ReadObject (ps, _) ->
let rec goodPath agg k lastV ps =
match Decoder.withPropertyTag k decode lastV with
| JPass v ->
let nextAgg = (k,v)::agg
match ps with
| [] -> JsonResult.pass nextAgg
| (nextK,nextV)::nextPs -> goodPath nextAgg nextK nextV nextPs
| JFail errs ->
badPathTransfer [errs] ps
and badPath (aggErrs: JsonFailure list) k lastV ps =
match Decoder.withPropertyTag k decode lastV with
| JFail errs ->
badPathTransfer (errs::aggErrs) ps
| _ ->
badPathTransfer aggErrs ps
and badPathTransfer aggErrs ps =
match ps with
| [] -> JsonResult.fails aggErrs
| (nextK,nextV)::nextPs -> badPath aggErrs nextK nextV nextPs
match ps with
| [] -> JsonResult.pass []
| (initK,initV)::initPs -> goodPath [] initK initV initPs
let toPropertyList = function
| WriteObject ps -> List.rev ps
| ReadObject (ps, _) -> List.rev ps
let ofPropertyListWithCustomKey (toString: 'a -> string) (encode: JsonEncoder<'b>) (ps: ('a * 'b) list): JsonObject =
let rec inner agg = function
| [] -> WriteObject agg
| (k,v) :: ps ->
inner ((toString k, encode v) :: agg) ps
inner [] ps
let ofPropertyListWith (encode: JsonEncoder<'a>) (ps: (string * 'a) list): JsonObject =
ofPropertyListWithCustomKey id encode ps
let ofPropertyList (ps: (string * Json) list): JsonObject =
List.rev ps
|> WriteObject
let toMapWithCustomKeyQuick (parse: Decoder<string,'k>) (decode: Decoder<Json,'v>) =
toPropertyListWithCustomKeyQuick parse decode
|> Decoder.map Map.ofList
let toMapWithCustomKey (parse: Decoder<string,'k>) (decode: Decoder<Json,'v>) =
toPropertyListWithCustomKey parse decode
|> Decoder.map Map.ofList
let toMapWithQuick (decode: Decoder<Json,'v>) =
toPropertyListWithQuick decode
|> Decoder.map Map.ofList
let toMapWith (decode: Decoder<Json,'v>) =
toPropertyListWith decode
|> Decoder.map Map.ofList
let toMap = function
| WriteObject ps -> List.rev ps |> Map.ofList
| ReadObject (_, mps) -> mps
let ofMap m = ReadObject (mapToList m, m)
let ofMapWith (encode: JsonEncoder<'a>) (m: Map<string, 'a>): JsonObject =
let newMap = Map.map (fun _ a -> encode a) m
ReadObject (mapToList newMap, newMap)
let ofMapWithCustomKey (toString: 'k -> string) (encode: JsonEncoder<'v>) (m: Map<'k, 'v>): JsonObject =
let newList =
mapToList m
|> List.map (fun (k,v) -> (toString k, encode v))
ReadObject (newList, Map.ofList newList)
let toJson jObj = Json.Object jObj
module Json =
let Null: Json = Json.Null
[<AutoOpen>]
module Parsing =
module Parser =
open FParsec
let ws = spaces // eats any whitespace
let inline str s = pstring s
let stringLiteral : Parser<string,unit> =
let escape = anyOf "\"\\/bfnrt"
|>> function
| 'b' -> "\b"
| 'f' -> "\u000C"
| 'n' -> "\n"
| 'r' -> "\r"
| 't' -> "\t"
| c -> string c // every other char is mapped to itself
let unicodeEscape =
str "u" >>. pipe4 hex hex hex hex (fun h3 h2 h1 h0 ->
let hex2int c = (int c &&& 15) + (int c >>> 6)*9 // hex char to int
(hex2int h3)*4096 + (hex2int h2)*256 + (hex2int h1)*16 + hex2int h0
|> char |> string
)
between (str "\"") (str "\"")
(stringsSepBy (manySatisfy (fun c -> c <> '"' && c <> '\\'))
(str "\\" >>. (escape <|> unicodeEscape)))
let jstring = stringLiteral |>> Json.String
let jsonNumOpts = NumberLiteralOptions.AllowFraction ||| NumberLiteralOptions.AllowExponent ||| NumberLiteralOptions.AllowMinusSign ||| NumberLiteralOptions.AllowPlusSign
let jnumber : Parser<Json,unit> =
fun stream ->
let reply = numberLiteralE jsonNumOpts (ErrorMessageList(ErrorMessage.Expected("JSON number"))) stream
if reply.Status = ReplyStatus.Ok then
Reply(Json.Number reply.Result.String)
else
Reply(reply.Status, reply.Error)
let jtrue = stringReturn "true" Json.True
let jfalse = stringReturn "false" Json.False
let jnull = stringReturn "null" Json.Null
// jvalue, jlist and jobject are three mutually recursive grammar productions.
// In order to break the cyclic dependency, we make jvalue a parser that
// forwards all calls to a parser in a reference cell.
let jvalue, jvalueRef = createParserForwardedToRef() // initially jvalueRef holds a reference to a dummy parser
let listBetweenStrings sOpen sClose pElement f =
between (str sOpen) (str sClose) (ws >>. sepBy (pElement .>> ws) (str "," .>> ws) |>> f)
let keyValue = tuple2 stringLiteral (ws >>. str ":" >>. ws >>. jvalue)
let jlist = listBetweenStrings "[" "]" jvalue Json.Array
let toJsonObject = fun lst -> let map = Map.ofList lst in ReadObject (lst,map) |> Json.Object
let jobject = listBetweenStrings "{" "}" keyValue toJsonObject
do jvalueRef := choice [jobject
jlist
jstring
jnumber
jtrue
jfalse
jnull]
let json = ws >>. jvalue .>> ws .>> eof
let parseJsonString str = run json str
let parseJsonStream stream =
runParserOnStream json () "" stream System.Text.Encoding.UTF8
let handleParserResult = function
| Success (json, _, _) -> JsonResult.pass json
| Failure (e, _, _) -> JsonResult.invalidJson e
module Json =
let parse s =
if System.String.IsNullOrWhiteSpace s then
JsonResult.noInput
else
Parser.parseJsonString s
|> Parser.handleParserResult
let parseStream (stream : #System.IO.Stream) =
Parser.parseJsonStream stream
|> Parser.handleParserResult
[<AutoOpen>]
module Formatting =
open System.Globalization
let escapeChars =
[| '"'; '\\'; '\n'; '\r'; '\t'; '\b'; '\f'
'\u0000'; '\u0001'; '\u0002'; '\u0003'
'\u0004'; '\u0005'; '\u0006'; '\u0007'
'\u000B'; '\u000E'; '\u000F'
'\u0010'; '\u0011'; '\u0012'; '\u0013'
'\u0014'; '\u0015'; '\u0016'; '\u0017'
'\u0018'; '\u0019'; '\u001A'; '\u001B'
'\u001C'; '\u001D'; '\u001E'; '\u001F' |]
let isEscapeChar = function
| '"' | '\\' -> true
| c when c >= '\u0000' && c <= '\u001F' -> true
| _ -> false
let isEscapeCharPred = System.Predicate<_> isEscapeChar
let escaped = function
| '"' -> @"\"""
| '\\' -> @"\\"
| '\n' -> @"\n"
| '\r' -> @"\r"
| '\t' -> @"\t"
| '\f' -> @"\f"
| '\b' -> @"\b"
| '\u0000' -> @"\u0000"
| '\u0001' -> @"\u0001"
| '\u0002' -> @"\u0002"
| '\u0003' -> @"\u0003"
| '\u0004' -> @"\u0004"
| '\u0005' -> @"\u0005"
| '\u0006' -> @"\u0006"
| '\u0007' -> @"\u0007"
| '\u000B' -> @"\u000B"
| '\u000E' -> @"\u000E"
| '\u000F' -> @"\u000F"
| '\u0010' -> @"\u0010"
| '\u0011' -> @"\u0011"
| '\u0012' -> @"\u0012"
| '\u0013' -> @"\u0013"
| '\u0014' -> @"\u0014"
| '\u0015' -> @"\u0015"
| '\u0016' -> @"\u0016"
| '\u0017' -> @"\u0017"
| '\u0018' -> @"\u0018"
| '\u0019' -> @"\u0019"
| '\u001A' -> @"\u001A"
| '\u001B' -> @"\u001B"
| '\u001C' -> @"\u001C"
| '\u001D' -> @"\u001D"
| '\u001E' -> @"\u001E"
| '\u001F' -> @"\u001F"
| c -> @"\u" + (int c).ToString("X4", CultureInfo.InvariantCulture)
type PropertyNameSpacing =
| NoSpaceBetweenNameAndValue
| SpaceBetweenNameAndValue
type ElementSpacing =
| NoSpaceBetweenElements
| SpaceBetweenElements
| NewLineBetweenElements of indentSpaces:int
type JsonFormattingOptions =
{ PropertyNameSpacing : PropertyNameSpacing
ElementSpacing : ElementSpacing }
static member Compact =
{ PropertyNameSpacing = NoSpaceBetweenNameAndValue
ElementSpacing = NoSpaceBetweenElements }
static member SingleLine =
{ PropertyNameSpacing = SpaceBetweenNameAndValue
ElementSpacing = SpaceBetweenElements }
static member Pretty =
{ PropertyNameSpacing = SpaceBetweenNameAndValue
ElementSpacing = NewLineBetweenElements 2 }
module StringBuilder =
open System.Text
let inline append (sb: StringBuilder) (s: string) =
sb.Append s |> ignore
let inline appendSubstr (sb: StringBuilder) (s: string) (start: int) (count: int) =
sb.Append (s, start, count) |> ignore
let inline appendChar (sb: StringBuilder) (c: char) =
sb.Append c |> ignore
let inline appendCharRep (sb: StringBuilder) (c: char) (repeats: int) =
sb.Append (c, repeats) |> ignore
let writeString (sb:System.Text.StringBuilder) (cs:string) =
let rec escapeState index =
append sb (escaped cs.[index])
let nextIndex = index + 1
if nextIndex < cs.Length then
if isEscapeChar cs.[nextIndex] |> not then
coreState nextIndex
else
escapeState nextIndex
and coreState index =
let nextEscapeIndex = cs.IndexOfAny(escapeChars, index)
if nextEscapeIndex = -1 then
appendSubstr sb cs index (cs.Length - index)
else
appendSubstr sb cs index (nextEscapeIndex - index)
escapeState nextEscapeIndex
coreState 0
let appendSpaceBetweenElements sb { ElementSpacing = es } level =
match es, level with
| NoSpaceBetweenElements, _ -> ()
| SpaceBetweenElements, _ -> appendChar sb ' '
| NewLineBetweenElements _, 0 -> appendChar sb '\n'
| NewLineBetweenElements s, l -> appendChar sb '\n'; appendCharRep sb ' ' (s * l |> int)
let addNameSeparator sb { PropertyNameSpacing = pns } =
match pns with
| NoSpaceBetweenNameAndValue -> appendChar sb ':'
| SpaceBetweenNameAndValue -> append sb ": "
let rec formatJson sb options level = function
| Json.Object (WriteObject props)
| Json.Object (ReadObject (props,_)) -> formatObject sb options level props
| Json.Array elems -> formatArray sb options level elems
| Json.String s -> formatString sb s
| Json.Number x -> formatNumber sb x
| Json.True -> append sb "true"
| Json.False -> append sb "false"
| Json.Null -> append sb "null"
and formatObject sb options level props =
let newLevel = level + 1
appendChar sb '{'
appendSpaceBetweenElements sb options newLevel
joinObject sb options newLevel props
appendSpaceBetweenElements sb options level
appendChar sb '}'
and joinObject sb options level values =
match values with
| [] -> ()
| [v] -> formatProperty sb options level v
| v :: vs ->
joinObject sb options level vs
appendChar sb ','
appendSpaceBetweenElements sb options level
formatProperty sb options level v
and formatProperty sb options level (k,v) =
formatString sb k
addNameSeparator sb options
formatJson sb options level v
and formatArray sb options level elems =
let newLevel = level + 1
appendChar sb '['
appendSpaceBetweenElements sb options newLevel
joinArray sb options newLevel elems
appendSpaceBetweenElements sb options level
appendChar sb ']'
and joinArray sb options level values =
match values with
| [] -> ()
| [v] -> formatJson sb options level v
| v :: vs ->
formatJson sb options level v
appendChar sb ','
appendSpaceBetweenElements sb options level
joinArray sb options level vs
and formatString sb str =
appendChar sb '"'
writeString sb str
appendChar sb '"'
and formatNumber sb n =
append sb n
[<RequireQualifiedAccess>]
module Json =
let formatWith options json =
let sb = System.Text.StringBuilder ()
StringBuilder.formatJson sb options 0 json
sb.ToString()
let format json =
formatWith JsonFormattingOptions.Compact json
[<AutoOpen>]
module Serialization =
open System.Globalization
module Json =
module Encode =
let buildWith (builder: ObjectBuilder<'a>) (a: 'a): Json =
builder a JsonObject.empty
|> JsonObject.toJson
let inline buildWithInline (builder: ObjectBuilder<'a>) (a: 'a): Json =
builder a JsonObject.empty
|> JsonObject.toJson
let required (encode : JsonEncoder<'a>) k a jObj =
JsonObject.add k (encode a) jObj
let optional encode k aO jObj =
match aO with
| Some a -> required encode k a jObj
| None -> jObj
let inline ifNotEqual x encode k a jObj =
if x = a then jObj
else required encode k a jObj
let conditional pred encode k a jObj =
if pred a then required encode k a jObj
else jObj
let requiredMixin (build: ObjectBuilder<'a>) a jObj =
build a jObj
let optionalMixin build aO jObj =
match aO with
| Some a -> buildWith a jObj
| None -> jObj
let ref<'a> (): JsonEncoder<'a> ref * JsonEncoder<'a> =
let innerRef = ref (Unchecked.defaultof<JsonEncoder<'a>>)
innerRef, (fun a -> (!innerRef) a)
let lazily (lazyEncode: Lazy<JsonEncoder<'a>>): JsonEncoder<'a> =
fun a -> lazyEncode.Force() a
let delay (u2aD: unit -> JsonEncoder<'a>): JsonEncoder<'a> =
let lazified = lazy (u2aD ())
lazily lazified
let delayWith (x2aD: 'x -> JsonEncoder<'a>) (x: 'x): JsonEncoder<'a> =
let lazified = lazy (x2aD x)
lazily lazified
let json json: Json = json
let jsonObject (jObj: JsonObject): Json =
JsonObject.toJson jObj
let jsonObjectWith (encode: ObjectBuilder<'a>) (a: 'a): Json =
buildWith encode a
let propertyList (ps: (string * Json) list): Json =
JsonObject.ofPropertyList ps
|> jsonObject
let propertyListWith (encode: JsonEncoder<'a>) (ps: (string * 'a) list): Json =
JsonObject.ofPropertyListWith encode ps
|> jsonObject
let list (els: Json list): Json =
Json.Array els
let listWith (encode: JsonEncoder<'a>) (els: 'a list): Json =
List.map encode els
|> list
let array (els: Json array): Json =
List.ofArray els
|> list
let arrayWith (encode: JsonEncoder<'a>) (els: 'a array): Json =
Array.map encode els
|> array
let option (jO: Json option): Json =
Option.defaultValue Null jO
let optionWith (encode: JsonEncoder<'a>) (aO: 'a option): Json =
Option.map encode aO
|> option
let result (jR : Result<Json, Json>) : Json =
match jR with
| Ok(a) -> a
| Error(b) -> b
let resultWith (encodeA: JsonEncoder<'a>) (encodeB: JsonEncoder<'b>) (abR: Result<'a, 'b>): Json =
abR
|> Result.map encodeA
|> Result.mapError encodeB
|> result
// let set (els: Set<Json>): Json =
// Set.toList els
// |> list
let setWith (encode: JsonEncoder<'a>) (els: Set<'a>): Json =
Set.toList els
|> listWith encode
let map (m: Map<string, Json>): Json =
JsonObject.ofMap m
|> jsonObject
let mapWith (encode: JsonEncoder<'a>) (m: Map<string, 'a>): Json =
JsonObject.ofMapWith encode m
|> jsonObject
let mapWithCustomKey (toString: 'a -> string) (encode: JsonEncoder<'b>) (m: Map<'a, 'b>): Json =
JsonObject.ofMapWithCustomKey toString encode m
|> jsonObject
let tuple2 (encodeA: JsonEncoder<'a>) (encodeB: JsonEncoder<'b>) ((a : 'a), (b : 'b)): Json =
list
[ encodeA a
encodeB b ]
let tuple3 (encodeA: JsonEncoder<'a>) (encodeB: JsonEncoder<'b>) (encodeC: JsonEncoder<'c>) ((a : 'a), (b : 'b), (c: 'c)): Json =
list
[ encodeA a
encodeB b
encodeC c ]
let tuple4 (encodeA: JsonEncoder<'a>) (encodeB: JsonEncoder<'b>) (encodeC: JsonEncoder<'c>) (encodeD: JsonEncoder<'d>) ((a : 'a), (b : 'b), (c: 'c), (d: 'd)): Json =
list
[ encodeA a
encodeB b
encodeC c
encodeD d ]
let tuple5 (encodeA: JsonEncoder<'a>) (encodeB: JsonEncoder<'b>) (encodeC: JsonEncoder<'c>) (encodeD: JsonEncoder<'d>) (encodeE: JsonEncoder<'e>) ((a : 'a), (b : 'b), (c: 'c), (d: 'd), (e: 'e)): Json =
list
[ encodeA a
encodeB b
encodeC c
encodeD d
encodeE e ]
let tuple6 (encodeA: JsonEncoder<'a>) (encodeB: JsonEncoder<'b>) (encodeC: JsonEncoder<'c>) (encodeD: JsonEncoder<'d>) (encodeE: JsonEncoder<'e>) (encodeF: JsonEncoder<'f>) ((a : 'a), (b : 'b), (c: 'c), (d: 'd), (e: 'e), (f: 'f)): Json =
list
[ encodeA a
encodeB b
encodeC c
encodeD d
encodeE e
encodeF f ]
let tuple7 (encodeA: JsonEncoder<'a>) (encodeB: JsonEncoder<'b>) (encodeC: JsonEncoder<'c>) (encodeD: JsonEncoder<'d>) (encodeE: JsonEncoder<'e>) (encodeF: JsonEncoder<'f>) (encodeG: JsonEncoder<'g>) ((a : 'a), (b : 'b), (c: 'c), (d: 'd), (e: 'e), (f: 'f), (g: 'g)): Json =
list
[ encodeA a
encodeB b
encodeC c
encodeD d
encodeE e
encodeF f
encodeG g ]
let string (str: string): Json =
Json.String str
let number (n: string): Json =
Json.Number n
let int16 (n: int16): Json =
n.ToString(CultureInfo.InvariantCulture)
|> number
let int (n: int): Json =
n.ToString(CultureInfo.InvariantCulture)
|> number
let int64 (n: int64): Json =
n.ToString(CultureInfo.InvariantCulture)
|> number
let uint16 (n: uint16): Json =
n.ToString(CultureInfo.InvariantCulture)
|> number
let uint32 (n: uint32): Json =
n.ToString(CultureInfo.InvariantCulture)
|> number
let uint64 (n: uint64): Json =
n.ToString(CultureInfo.InvariantCulture)
|> number
let single (n: single): Json =
n.ToString("R", CultureInfo.InvariantCulture)
|> number
let float (n: float): Json =
n.ToString("G17", CultureInfo.InvariantCulture)
|> number
let decimal (n: decimal): Json =
n.ToString(CultureInfo.InvariantCulture)
|> number
let bigint (n: bigint): Json =
n.ToString("R", CultureInfo.InvariantCulture)
|> number
let dateTime (dt: System.DateTime): Json =
dt.ToUniversalTime().ToString("o", CultureInfo.InvariantCulture)
|> string
let dateTimeOffset (dt: System.DateTimeOffset): Json =
dt.ToString("o", CultureInfo.InvariantCulture)
|> string
let guid (g: System.Guid): Json =
g.ToString("N")
|> string
let bytes (bs: byte array): Json =
System.Convert.ToBase64String bs
|> string
let bool (b: bool): Json =
if b then Json.True else Json.False
let unit () : Json =
Json.Null
let intList = listWith int
let intArray = arrayWith int
let intSet = setWith int
let stringList = listWith string
let stringArray = arrayWith string
let stringSet = setWith string
let stringMap = mapWith string
module Decode =
open Operators
let always a : Decoder<'x,'a> =
Decoder.alwaysPass a
let json : Decoder<Json,Json> = JsonResult.pass
let unit : Decoder<Json,unit> =
do ()
function
| Json.Null -> JsonResult.pass ()
| json -> JsonResult.typeMismatch JsonMemberType.Null json
let jsonObject : Decoder<Json,JsonObject> =
(do ())
function
| Json.Object o -> JsonResult.pass o
| json -> JsonResult.typeMismatch JsonMemberType.Object json
let jsonObjectWith (decode: Decoder<JsonObject,'a>) : Decoder<Json,'a> =
jsonObject >=> decode
let required (decode: Decoder<Json,'a>) (k: string) : Decoder<JsonObject,'a> =
let binder = Decoder.withPropertyTag k decode
fun jObj ->
JsonObject.find k jObj
|> JsonResult.bind binder
let inline requiredInline (decode: Decoder<Json,'a>) k : Decoder<JsonObject,'a> =
fun jObj ->
JsonObject.find k jObj
|> JsonResult.bind (Decoder.withPropertyTagInline k decode)
let optional (decode: Decoder<Json,'a>) (k: string) : Decoder<JsonObject,'a option> =
fun jObj ->
match JsonObject.tryFind k jObj with
| Some json ->
match Decoder.withPropertyTag k decode json with
| JPass x -> JsonResult.pass (Some x)
| JFail f -> JsonResult.fail f
| None -> JsonResult.pass None
let inline optionalInline (decode: Decoder<Json,'a>) (k: string) : Decoder<JsonObject,'a option> =
fun jObj ->
match JsonObject.tryFind k jObj with
| Some json ->
match Decoder.withPropertyTagInline k decode json with
| JPass x -> JsonResult.pass (Some x)
| JFail f -> JsonResult.fail f
| None -> JsonResult.pass None
let withDefault (def: 's) : Decoder<'s option, 's> =
fun sO -> JPass (Option.defaultValue def sO)
let optionalList (decode: Decoder<Json,'a list>) (k: string) : Decoder<JsonObject,'a list> =
optional decode k >=> withDefault []
let optionalMap (decode: Decoder<Json,Map<'a,'b>>) (k:string) : Decoder<JsonObject,Map<'a,'b>> =
optional decode k >=> withDefault Map.empty
let optionalArray (decode: Decoder<Json,'a array>) (k: string): Decoder<JsonObject,'a array> =
optional decode k >=> withDefault [||]
let requiredMixin (decode: Decoder<Json,'a>) : Decoder<JsonObject,'a> =
fun jObj ->
Encode.jsonObject jObj
|> decode
let ref<'s, 'a> (): Decoder<'s,'a> ref * Decoder<'s,'a> =
let innerRef = ref (Unchecked.defaultof<Decoder<'s,'a>>)
innerRef, (fun s -> (!innerRef) s)
let lazily (lazyDecode: Lazy<Decoder<'s,'a>>): Decoder<'s,'a> =
fun s ->
lazyDecode.Force() s
let delay (u2aD: unit -> Decoder<'s,'a>): Decoder<'s,'a> =
let lazified = lazy (u2aD ())
lazily lazified
let delayWith (x2aD: 'x -> Decoder<'s,'a>) (x: 'x): Decoder<'s,'a> =
let lazified = lazy (x2aD x)
lazily lazified
let either (decodeA: Decoder<'s,'a>) (decodeB: Decoder<'s,'a>) =
fun s ->
match Decoder.withChoiceTag 0u decodeA s with
| (JPass _) as goodResult -> goodResult
| JFail errs1 ->
match Decoder.withChoiceTag 1u decodeB s with
| (JPass _) as goodResult -> goodResult
| JFail errs2 ->
JsonResult.fail (JsonFailure.mappend errs1 errs2)
let oneOf (decoders: Decoder<'s,'a> list) : Decoder<'s,'a> =
let rec failing decode decoders (aggErrs: JsonFailure list) i (s: 's) =
match Decoder.withChoiceTag i decode s with
| (JPass _) as goodResult -> goodResult
| JFail errs ->
let nextAggErrs = errs::aggErrs
match decoders with
| [] -> JsonResult.fails nextAggErrs
| nextDecode::nextDecoders ->
failing nextDecode nextDecoders nextAggErrs (i + 1u) s
match decoders with
| [] -> fun s -> JsonResult.deserializationError (exn "No decoders provided to oneOf")
| [decode] -> decode
| initDecode::initDecoders -> failing initDecode initDecoders [] 0u
let optionalMixin (decode: Decoder<Json,'a>) : Decoder<JsonObject,'a option> =
either (requiredMixin decode >-> Some) (always None)
let assertThat (pred: 's -> bool) (failMsg: string) : Decoder<'s,'s> =
fun s ->
if pred s then
JsonResult.pass s
else
JsonResult.raise (exn failMsg)
let propertyList : Decoder<Json,(string * Json) list> =
JsonObject.toPropertyList <!> jsonObject
let propertyListWithQuick (decode: Decoder<Json,'a>) : Decoder<Json,(string * 'a) list> =
jsonObject >=> JsonObject.toPropertyListWithQuick decode
let propertyListWith (decode: Decoder<Json,'a>) : Decoder<Json,(string * 'a) list> =
jsonObject >=> JsonObject.toPropertyListWith decode
let propertyListWithCustomKeyQuick (parse: string -> JsonResult<'k>) (decode: Decoder<Json,'v>) : Decoder<Json,('k * 'v) list> =
jsonObject >=> JsonObject.toPropertyListWithCustomKeyQuick parse decode
let propertyListWithCustomKey (parse: string -> JsonResult<'k>) (decode: Decoder<Json,'v>) : Decoder<Json,('k * 'v) list> =
jsonObject >=> JsonObject.toPropertyListWithCustomKey parse decode
let list : Decoder<Json,Json list> =
do ()
function
| Json.Array a -> JsonResult.pass a
| json -> JsonResult.typeMismatch JsonMemberType.Array json
let array : Decoder<Json,Json array>=
Array.ofList <!> list
let arrayWithQuick (decode: Decoder<Json,'a>) : Decoder<Json,'a[]> =
let idλ = (do ()); fun (x: JsonFailure list) -> x
let singletonArrayλ = (do ()); fun (x: 'a) -> [|x|]
let rec goodPath (agg: 'a[]) idx lastX xs =
match Decoder.withIndexTag idx decode lastX with
| JPass x ->
agg.[int idx] <- x
match xs with
| [] -> JsonResult.pass agg
| nextX::nextXs -> goodPath agg (idx + 1u) nextX nextXs
| JFail errs ->
JsonResult.fail errs
list >=> function
| [] -> JsonResult.pass [||]
| [x] -> decode x |> JsonResult.map singletonArrayλ
| x::xs -> goodPath (Array.zeroCreate (List.length xs + 1)) 0u x xs
let arrayWith (decode: Decoder<Json,'a>) : Decoder<Json,'a[]> =
let idλ = (do ()); fun (x: JsonFailure list) -> x
let singletonArrayλ = (do ()); fun (x: 'a) -> [|x|]
let rec goodPath (agg: 'a[]) idx lastX xs =
match Decoder.withIndexTag idx decode lastX with
| JPass x ->
agg.[int idx] <- x
match xs with
| [] -> JsonResult.pass agg
| nextX::nextXs -> goodPath agg (idx + 1u) nextX nextXs
| JFail errs ->
badPathTransfer [errs] idx xs
and badPath (aggErrs: JsonFailure list) idx lastX xs =
match Decoder.withIndexTag idx decode lastX with
| JFail errs ->
badPathTransfer (errs::aggErrs) idx xs
| _ ->
badPathTransfer aggErrs idx xs
and badPathTransfer aggErrs idx xs =
match xs with
| [] -> JsonResult.fails aggErrs
| nextX::nextXs -> badPath aggErrs (idx + 1u) nextX nextXs
list >=> function
| [] -> JsonResult.pass [||]
| [x] -> decode x |> JsonResult.map singletonArrayλ
| x::xs -> goodPath (Array.zeroCreate (List.length xs + 1)) 0u x xs
let listWithQuick (decode: Decoder<Json,'a>) : Decoder<Json,'a list> =
Array.toList <!> arrayWithQuick decode
let listWith (decode: Decoder<Json,'a>) : Decoder<Json,'a list> =
Array.toList <!> arrayWith decode
let optionWith (decode: Decoder<Json,'a>) : Decoder<Json,'a option> =
let decode =
oneOf
[ unit >=> always None
decode >-> Some ]
fun json -> decode json
let option : Decoder<Json,Json option> =
optionWith json
// let set (json: Json) =
// Set.ofList <!> list
let setWithQuick (decode: Decoder<Json,'a>) : Decoder<Json,Set<'a>> =
Set.ofArray <!> arrayWithQuick decode
let setWith (decode: Decoder<Json,'a>) : Decoder<Json,Set<'a>> =
Set.ofArray <!> arrayWith decode
let resultWith (decodeA: Decoder<Json, 'a>) (decodeB : Decoder<Json, 'b>) : Decoder<Json, Result<'a, 'b>> =
fun s ->
match Decoder.withChoiceTag 0u decodeA s with
| (JPass _) as goodResult -> JsonResult.map Ok goodResult
| JFail errs1 ->
match Decoder.withChoiceTag 1u decodeB s with
| (JPass _) as goodResult -> JsonResult.map Error goodResult
| JFail errs2 ->
JsonResult.fail (JsonFailure.mappend errs1 errs2)
let map : Decoder<Json,Map<string,Json>> =
JsonObject.toMap <!> jsonObject
let mapWithQuick (decode: Decoder<Json,'a>) : Decoder<Json,Map<string,'a>> =
Map.ofList <!> (jsonObject >=> JsonObject.toPropertyListWithQuick decode)
let mapWith (decode: Decoder<Json,'a>) : Decoder<Json,Map<string,'a>> =
Map.ofList <!> (jsonObject >=> JsonObject.toPropertyListWith decode)
let mapWithCustomKeyQuick (parse: string -> JsonResult<'k>) (decode: Decoder<Json,'v>) : Decoder<Json,Map<'k,'v>> =
Map.ofList <!> (jsonObject >=> JsonObject.toPropertyListWithCustomKeyQuick parse decode)
let mapWithCustomKey (parse: string -> JsonResult<'k>) (decode: Decoder<Json,'v>) : Decoder<Json,Map<'k,'v>> =
Map.ofList <!> (jsonObject >=> JsonObject.toPropertyListWithCustomKey parse decode)
let inline listToTuple2 lst =
match lst with
| [a;b] -> JsonResult.pass (a, b)
| [_] -> JsonResult.deserializationError (exn "2-Tuple has only one element")
| [] -> JsonResult.deserializationError (exn "2-Tuple has zero elements")
| _ -> JsonResult.deserializationError (exn "2-Tuple has too many elements")
let tuple2 : Decoder<Json,Json * Json> =
list >=> listToTuple2
let inline mkTuple2 a b = (a, b)
let inline tuple2WithTaggedDecoders f decodeA decodeB =
let tagA = Decoder.withIndexTag 0u decodeA
let tagB = Decoder.withIndexTag 1u decodeB
f mkTuple2 tagA tagB
let inline jsonTuple2ToTuple2Quick mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) =
fun (a, b) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeB b
let inline jsonTuple2ToTuple2 mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) =
fun (a, b) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeB b
let tuple2WithQuick (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) : Decoder<Json,'a * 'b> =
tuple2 >=> tuple2WithTaggedDecoders jsonTuple2ToTuple2Quick decodeA decodeB
let tuple2With (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) : Decoder<Json,'a * 'b> =
tuple2 >=> tuple2WithTaggedDecoders jsonTuple2ToTuple2 decodeA decodeB
let inline listToTuple3 lst =
match lst with
| [a;b;c] -> JsonResult.pass (a, b, c)
| x when List.length x > 3 -> JsonResult.deserializationError (exn "3-Tuple has excess elements")
| _ -> JsonResult.deserializationError (exn "3-Tuple has insufficient elements")
let tuple3 =
list >=> listToTuple3
let inline mkTuple3 a b c = (a, b, c)
let inline tuple3WithTaggedDecoders f decodeA decodeB decodeC =
let tagA = Decoder.withIndexTag 0u decodeA
let tagB = Decoder.withIndexTag 1u decodeB
let tagC = Decoder.withIndexTag 2u decodeC
f mkTuple3 tagA tagB tagC
let inline jsonTuple3ToTuple3Quick mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) =
fun (a, b, c) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeB b
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeC c
let inline jsonTuple3ToTuple3 mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) =
fun (a, b, c) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeB b
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeC c
let tuple3WithQuick (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>): Decoder<Json,'a * 'b * 'c> =
tuple3 >=> tuple3WithTaggedDecoders jsonTuple3ToTuple3Quick decodeA decodeB decodeC
let tuple3With (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>): Decoder<Json,'a * 'b * 'c> =
tuple3 >=> tuple3WithTaggedDecoders jsonTuple3ToTuple3 decodeA decodeB decodeC
let inline listToTuple4 lst =
match lst with
| [a;b;c;d] -> JsonResult.pass (a, b, c, d)
| x when List.length x > 4 -> JsonResult.deserializationError (exn "4-Tuple has excess elements")
| _ -> JsonResult.deserializationError (exn "4-Tuple has insufficient elements")
let tuple4 =
list >=> listToTuple4
let inline mkTuple4 a b c d = (a, b, c, d)
let inline tuple4WithTaggedDecoders f decodeA decodeB decodeC decodeD =
let tagA = Decoder.withIndexTag 0u decodeA
let tagB = Decoder.withIndexTag 1u decodeB
let tagC = Decoder.withIndexTag 2u decodeC
let tagD = Decoder.withIndexTag 3u decodeD
f mkTuple4 tagA tagB tagC tagD
let inline jsonTuple4ToTuple4Quick mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) =
fun (a, b, c, d) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeB b
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeC c
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeD d
let inline jsonTuple4ToTuple4 mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) =
fun (a, b, c, d) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeB b
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeC c
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeD d
let tuple4WithQuick (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) =
tuple4 >=> tuple4WithTaggedDecoders jsonTuple4ToTuple4Quick decodeA decodeB decodeC decodeD
let tuple4With (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) =
tuple4 >=> tuple4WithTaggedDecoders jsonTuple4ToTuple4 decodeA decodeB decodeC decodeD
let inline listToTuple5 lst =
match lst with
| [a;b;c;d;e] -> JsonResult.pass (a, b, c, d, e)
| x when List.length x > 5 -> JsonResult.deserializationError (exn "5-Tuple has excess elements")
| _ -> JsonResult.deserializationError (exn "5-Tuple has insufficient elements")
let tuple5 =
list >=> listToTuple5
let inline mkTuple5 a b c d e = (a, b, c, d, e)
let inline tuple5WithTaggedDecoders f decodeA decodeB decodeC decodeD decodeE =
let tagA = Decoder.withIndexTag 0u decodeA
let tagB = Decoder.withIndexTag 1u decodeB
let tagC = Decoder.withIndexTag 2u decodeC
let tagD = Decoder.withIndexTag 3u decodeD
let tagE = Decoder.withIndexTag 4u decodeE
f mkTuple5 tagA tagB tagC tagD tagE
let inline jsonTuple5ToTuple5Quick mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) =
fun (a, b, c, d, e) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeB b
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeC c
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeD d
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeE e
let inline jsonTuple5ToTuple5 mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) =
fun (a, b, c, d, e) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeB b
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeC c
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeD d
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeE e
let tuple5WithQuick (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) =
tuple5 >=> tuple5WithTaggedDecoders jsonTuple5ToTuple5Quick decodeA decodeB decodeC decodeD decodeE
let tuple5With (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) =
tuple5 >=> tuple5WithTaggedDecoders jsonTuple5ToTuple5 decodeA decodeB decodeC decodeD decodeE
let listToTuple6 lst =
match lst with
| [a;b;c;d;e;f] -> JsonResult.pass (a, b, c, d, e, f)
| x when List.length x > 6 -> JsonResult.deserializationError (exn "6-Tuple has excess elements")
| _ -> JsonResult.deserializationError (exn "6-Tuple has insufficient elements")
let tuple6 =
list >=> listToTuple6
let inline mkTuple6 a b c d e f = (a, b, c, d, e, f)
let inline tuple6WithTaggedDecoders f decodeA decodeB decodeC decodeD decodeE decodeF =
let tagA = Decoder.withIndexTag 0u decodeA
let tagB = Decoder.withIndexTag 1u decodeB
let tagC = Decoder.withIndexTag 2u decodeC
let tagD = Decoder.withIndexTag 3u decodeD
let tagE = Decoder.withIndexTag 4u decodeE
let tagF = Decoder.withIndexTag 5u decodeF
f mkTuple6 tagA tagB tagC tagD tagE tagF
let inline jsonTuple6ToTuple6Quick mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) (decodeF: Decoder<Json,'f>) =
fun (a, b, c, d, e, f) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeB b
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeC c
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeD d
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeE e
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeF f
let inline jsonTuple6ToTuple6 mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) (decodeF: Decoder<Json,'f>) =
fun (a, b, c, d, e, f) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeB b
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeC c
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeD d
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeE e
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeF f
let tuple6WithQuick (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) (decodeF: Decoder<Json,'f>) =
tuple6 >=> tuple6WithTaggedDecoders jsonTuple6ToTuple6Quick decodeA decodeB decodeC decodeD decodeE decodeF
let tuple6With (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) (decodeF: Decoder<Json,'f>) =
tuple6 >=> tuple6WithTaggedDecoders jsonTuple6ToTuple6 decodeA decodeB decodeC decodeD decodeE decodeF
let inline listToTuple7 lst =
match lst with
| [a;b;c;d;e;f;g] -> JsonResult.pass (a, b, c, d, e, f, g)
| x when List.length x > 7 -> JsonResult.deserializationError (exn "7-Tuple has excess elements")
| _ -> JsonResult.deserializationError (exn "7-Tuple has insufficient elements")
let tuple7 =
list >=> listToTuple7
let inline mkTuple7 a b c d e f g = (a, b, c, d, e, f, g)
let inline tuple7WithTaggedDecoders f decodeA decodeB decodeC decodeD decodeE decodeF decodeG =
let tagA = Decoder.withIndexTag 0u decodeA
let tagB = Decoder.withIndexTag 1u decodeB
let tagC = Decoder.withIndexTag 2u decodeC
let tagD = Decoder.withIndexTag 3u decodeD
let tagE = Decoder.withIndexTag 4u decodeE
let tagF = Decoder.withIndexTag 5u decodeF
let tagG = Decoder.withIndexTag 6u decodeG
f mkTuple7 tagA tagB tagC tagD tagE tagF tagG
let inline jsonTuple7ToTuple7Quick mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) (decodeF: Decoder<Json,'f>) (decodeG: Decoder<Json,'g>) =
fun (a, b, c, d, e, f, g) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeB b
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeC c
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeD d
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeE e
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeF f
|> JsonResult.applyDelayedWithPolicy StopOnFirstError decodeG g
let inline jsonTuple7ToTuple7 mkTuple (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) (decodeF: Decoder<Json,'f>) (decodeG: Decoder<Json,'g>) =
fun (a, b, c, d, e, f, g) ->
JsonResult.map mkTuple (decodeA a)
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeB b
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeC c
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeD d
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeE e
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeF f
|> JsonResult.applyDelayedWithPolicy ContinueOnError decodeG g
let tuple7WithQuick (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) (decodeF: Decoder<Json,'f>) (decodeG: Decoder<Json,'g>) =
tuple7 >=> tuple7WithTaggedDecoders jsonTuple7ToTuple7Quick decodeA decodeB decodeC decodeD decodeE decodeF decodeG
let tuple7With (decodeA: Decoder<Json,'a>) (decodeB: Decoder<Json,'b>) (decodeC: Decoder<Json,'c>) (decodeD: Decoder<Json,'d>) (decodeE: Decoder<Json,'e>) (decodeF: Decoder<Json,'f>) (decodeG: Decoder<Json,'g>) =
tuple7 >=> tuple7WithTaggedDecoders jsonTuple7ToTuple7 decodeA decodeB decodeC decodeD decodeE decodeF decodeG
let number =
do ()
function
| Json.Number n -> JsonResult.pass n
| json -> JsonResult.typeMismatch JsonMemberType.Number json
let int16 =
number >=> Decoder.fromThrowingConverter (fun s -> System.Int16.Parse(s, CultureInfo.InvariantCulture))
let int =
number >=> Decoder.fromThrowingConverter (fun s -> System.Int32.Parse(s, CultureInfo.InvariantCulture))
let int64 =
number >=> Decoder.fromThrowingConverter (fun s -> System.Int64.Parse(s, CultureInfo.InvariantCulture))
let uint16 =
number >=> Decoder.fromThrowingConverter (fun s -> System.UInt16.Parse(s, CultureInfo.InvariantCulture))
let uint32 =
number >=> Decoder.fromThrowingConverter (fun s -> System.UInt32.Parse(s, CultureInfo.InvariantCulture))
let uint64 =
number >=> Decoder.fromThrowingConverter (fun s -> System.UInt64.Parse(s, CultureInfo.InvariantCulture))
let single =
number >=> Decoder.fromThrowingConverter (fun s -> System.Single.Parse(s, CultureInfo.InvariantCulture))
let float =
number >=> Decoder.fromThrowingConverter (fun s -> System.Double.Parse(s, CultureInfo.InvariantCulture))
let decimal =
number >=> Decoder.fromThrowingConverter (fun s -> System.Decimal.Parse(s, CultureInfo.InvariantCulture))
let bigint =
number >=> Decoder.fromThrowingConverter (fun s -> System.Numerics.BigInteger.Parse(s, CultureInfo.InvariantCulture))
let string =
do ()
function
| Json.String s -> JsonResult.pass s
| json -> JsonResult.typeMismatch JsonMemberType.String json
let dateTimeParser s = System.DateTime.ParseExact (s, [| "s"; "r"; "o" |], CultureInfo.InvariantCulture, System.Globalization.DateTimeStyles.AdjustToUniversal)
let dateTime =
string >=> Decoder.fromThrowingConverter dateTimeParser
let dateTimeOffsetParser s = System.DateTimeOffset.ParseExact (s, [| "yyyy-MM-dd'T'HH:mm:ss.FFFFFFF'Z'"; "o"; "r" |], CultureInfo.InvariantCulture, System.Globalization.DateTimeStyles.AssumeUniversal)
let dateTimeOffset =
string >=> Decoder.fromThrowingConverter dateTimeOffsetParser
let guid =
string >=> Decoder.fromThrowingConverter System.Guid.Parse
let bytes =
string >=> Decoder.fromThrowingConverter System.Convert.FromBase64String
let bool =
do ()
function
| Json.True -> JsonResult.pass true
| Json.False -> JsonResult.pass false
| json -> JsonResult.typeMismatch JsonMemberType.Bool json
let intArrayQuick = arrayWithQuick int
let stringArrayQuick = arrayWithQuick string
let intArray = arrayWith int
let stringArray = arrayWith string
let intListQuick = listWithQuick int
let stringListQuick = listWithQuick string
let intList = listWith int
let stringList = listWith string
let stringSetQuick = setWithQuick string
let stringSet = setWith string
let deserializeWith (decode: Decoder<Json,'a>) (str: string) =
Json.parse str
|> JsonResult.bind decode
let deserializeObjectWith (decode: Decoder<JsonObject,'a>) (str: string) =
Json.parse str
|> JsonResult.bind (Decode.jsonObject)
|> JsonResult.bind decode
let serializeWith (encode: JsonEncoder<'a>) (options: JsonFormattingOptions) (a: 'a) =
encode a
|> Json.formatWith options
let serializeObjectWith (builder: ObjectBuilder<'a>) (options: JsonFormattingOptions) (a: 'a) =
Encode.buildWith builder a
|> Json.formatWith options
module Optics =
type Lens<'a,'b> = ('a -> JsonResult<'b>) * ('b -> 'a -> 'a)
let get (l:Lens<'a,'b>) =
fst l
let set (l:Lens<'a,'b>) =
snd l
let compose (l1:Lens<'a,'b>) (l2:Lens<'b,'c>): Lens<'a,'c> =
(fun a -> fst l1 a |> JsonResult.bind (fst l2)), (fun c a -> match JsonResult.map (snd l2 c) (fst l1 a) with JPass b -> snd l1 b a; | _ -> a)
module JsonObject =
let key_ k =
JsonObject.find k, fun v jObj -> JsonObject.add k v jObj
module Json =
module E = Serialization.Json.Encode
module D = Serialization.Json.Decode
let Object__ = D.jsonObject, E.jsonObject
let Array__ = D.list, E.array
let String__ = D.string, E.string
let Number__ = D.number, E.number
let Bool__ = D.bool, E.bool
let Null__ = D.unit, E.unit
let Object_ = D.jsonObject, fun x _ -> E.jsonObject x
let Array_ = D.list, fun x _ -> E.list x
let String_ = D.string, fun x _ -> E.string x
let Number_ = D.number, fun x _ -> E.number x
let Bool_ = D.bool, fun x _ -> E.bool x
let Null_ = D.unit, fun () _ -> E.unit ()
let Int16_ : Lens<Json,int16> =
D.int16, fun x _ -> E.int16 x
let Int32_ : Lens<Json,int> =
D.int, fun x _ -> E.int x
let Int64_ : Lens<Json,int64> =
D.int64, fun x _ -> E.int64 x
let UInt16_ : Lens<Json,uint16> =
D.uint16, fun x _ -> E.uint16 x
let UInt32_ : Lens<Json,uint32> =
D.uint32, fun x _ -> E.uint32 x
let UInt64_ : Lens<Json,uint64> =
D.uint64, fun x _ -> E.uint64 x
let Single_ : Lens<Json,single> =
D.single, fun x _ -> E.single x
let Double_ : Lens<Json,float> =
D.float, fun x _ -> E.float x
let Decimal_ : Lens<Json,decimal> =
D.decimal, fun x _ -> E.decimal x
let BigInteger_ : Lens<Json,bigint> =
D.bigint, fun x _ -> E.bigint x
let DateTime_ : Lens<Json,System.DateTime> =
D.dateTime, fun x _ -> E.dateTime x
let DateTimeOffset_ : Lens<Json,System.DateTimeOffset> =
D.dateTimeOffset, fun x _ -> E.dateTimeOffset x
let Guid_ : Lens<Json,System.Guid> =
D.guid, fun x _ -> E.guid x
let Bytes_ : Lens<Json,byte array> =
D.bytes, fun x _ -> E.bytes x
let Property_ k =
compose Object_ (JsonObject.key_ k)
module JsonTransformer =
type Json<'a> = Json -> JsonResult<'a> * Json
module Json =
let init (a: 'a) : Json<'a> =
fun json ->
(JsonResult.pass a, json)
let error (e: JsonFailure) : Json<'a> =
fun json ->
(JsonResult.fail e, json)
let ofResult result : Json<'a> =
fun json ->
(result, json)
let bind (a2bJ: 'a -> Json<'b>) (aJ: Json<'a>) : Json<'b> =
fun json ->
match aJ json with
| JPass a, json' -> a2bJ a json'
| JFail e, json' -> JsonResult.fail e, json'
let apply (aJ: Json<'a>) (a2Jb: Json<'a -> 'b>) : Json<'b> =
fun json ->
match a2Jb json with
| JPass a2b, json' ->
match aJ json' with
| JPass a, json'' -> JsonResult.pass (a2b a), json''
| JFail e, json'' -> JsonResult.fail e, json''
| JFail e, json' -> JsonResult.fail e, json'
let map (f: 'a -> 'b) (m: Json<'a>) : Json<'b> =
fun json ->
match m json with
| JPass a, json -> JsonResult.pass (f a), json
| JFail e, json -> JsonResult.fail e, json
let map2 (a2b2c: 'a -> 'b -> 'c) (aJ: Json<'a>) (bJ: Json<'b>) : Json<'c> =
map a2b2c aJ
|> apply bJ
let map3 (a2b2c2d: 'a -> 'b -> 'c -> 'd) (aJ: Json<'a>) (bJ: Json<'b>) (cJ: Json<'c>) : Json<'d> =
map a2b2c2d aJ
|> apply bJ
|> apply cJ
let map4 (a2b2c2d2x: 'a -> 'b -> 'c -> 'd -> 'x) (aJ: Json<'a>) (bJ: Json<'b>) (cJ: Json<'c>) (dJ: Json<'d>) : Json<'x> =
map a2b2c2d2x aJ
|> apply bJ
|> apply cJ
|> apply dJ
let map5 (a2b2c2d2x2y: 'a -> 'b -> 'c -> 'd -> 'x -> 'y) (aJ: Json<'a>) (bJ: Json<'b>) (cJ: Json<'c>) (dJ: Json<'d>) (xJ: Json<'x>) : Json<'y> =
map a2b2c2d2x2y aJ
|> apply bJ
|> apply cJ
|> apply dJ
|> apply xJ
let map6 (a2b2c2d2x2y2z: 'a -> 'b -> 'c -> 'd -> 'x -> 'y -> 'z) (aJ: Json<'a>) (bJ: Json<'b>) (cJ: Json<'c>) (dJ: Json<'d>) (xJ: Json<'x>) (yJ: Json<'y>) : Json<'z> =
map a2b2c2d2x2y2z aJ
|> apply bJ
|> apply cJ
|> apply dJ
|> apply xJ
|> apply yJ
let toJsonReader (aJ:Json<'a>): Decoder<Json,'a> =
fun json ->
aJ json |> fst
module Operators =
let inline (>>=) m f = Json.bind f m
let inline (=<<) f m = Json.bind f m
let inline (<*>) f m = Json.apply m f
let inline (<!>) f m = Json.map f m
let inline ( *>) m1 m2 = Json.map2 (fun _ x -> x) m1 m2
let inline ( <*) m1 m2 = Json.map2 (fun x _ -> x) m1 m2
let (>=>) m1 m2 = m1 >> Json.bind m2
let (<=<) m2 m1 = m1 >> Json.bind m2
#nowarn "60"
type Json with
override x.ToString() =
Formatting.Json.format x
module Inference =
module Internal =
module E = Serialization.Json.Encode
module D = Serialization.Json.Decode
type ChironDefaults = ChironDefaults with
static member ToJson (jObj: JsonObject): Json = E.jsonObject jObj
static member ToJson (str: string): Json = E.string str
static member ToJson (n: int16): Json = E.int16 n
static member ToJson (n: int): Json = E.int n
static member ToJson (n: int64): Json = E.int64 n
static member ToJson (n: uint16): Json = E.uint16 n
static member ToJson (n: uint32): Json = E.uint32 n
static member ToJson (n: uint64): Json = E.uint64 n
static member ToJson (n: single): Json = E.single n
static member ToJson (n: float): Json = E.float n
static member ToJson (n: decimal): Json = E.decimal n
static member ToJson (n: bigint): Json = E.bigint n
static member ToJson (b: bool): Json = E.bool b
static member ToJson (dt: System.DateTime): Json = E.dateTime dt
static member ToJson (dt: System.DateTimeOffset): Json = E.dateTimeOffset dt
static member ToJson (g: System.Guid): Json = E.guid g
static member ToJson (j: Json): Json = E.json j
static member FromJson (_: JsonObject) = D.jsonObject
static member FromJson (_: string) = D.string
static member FromJson (_: int16) = D.int16
static member FromJson (_: int) = D.int
static member FromJson (_: int64) = D.int64
static member FromJson (_: uint16) = D.uint16
static member FromJson (_: uint32) = D.uint32
static member FromJson (_: uint64) = D.uint64
static member FromJson (_: single) = D.single
static member FromJson (_: float) = D.float
static member FromJson (_: decimal) = D.decimal
static member FromJson (_: bigint) = D.bigint
static member FromJson (_: bool) = D.bool
static member FromJson (_: System.DateTime) = D.dateTime
static member FromJson (_: System.DateTimeOffset) = D.dateTimeOffset
static member FromJson (_: System.Guid) = D.guid
static member FromJson (_: Json) = D.json
let inline encodeWithDefaults (defaults: ^def) (a: ^a): Json =
((^a or ^def) : (static member ToJson : ^a -> Json) a)
let inline encode (a: 'a) =
encodeWithDefaults ChironDefaults a
let inline decodeWithDefaults (defaults: ^def) (dummy: ^a): Decoder<Json,'a> =
((^a or ^def) : (static member FromJson : ^a -> Decoder<Json,'a>) dummy)
let inline decode (json: Json) : JsonResult<'a> =
decodeWithDefaults ChironDefaults Unchecked.defaultof<'a> json
type ChironDefaults with
static member inline ToJson (xs: 'a list): Json = E.listWith encode xs
static member inline ToJson (xs: 'a array): Json = E.arrayWith encode xs
static member inline ToJson (xO: 'a option): Json = E.optionWith encode xO
static member inline ToJson (xs: Set<'a>): Json = E.setWith encode xs
static member inline ToJson (m: Map<string, 'a>): Json = E.mapWith encode m
static member inline ToJson (r: Result<'a, 'b>): Json = E.resultWith encode encode r
static member inline ToJson (t): Json = E.tuple2 encode encode t
static member inline ToJson (t): Json = E.tuple3 encode encode encode t
static member inline ToJson (t): Json = E.tuple4 encode encode encode encode t
static member inline ToJson (t): Json = E.tuple5 encode encode encode encode encode t
static member inline ToJson (t): Json = E.tuple6 encode encode encode encode encode encode t
static member inline ToJson (t): Json = E.tuple7 encode encode encode encode encode encode encode t
static member inline FromJson (_: 'a list) = D.listWith decode
static member inline FromJson (_: 'a array): Decoder<Json,'a array> = D.arrayWith decode
static member inline FromJson (_: 'a option) = D.optionWith decode
static member inline FromJson (_: Set<'a>) = D.setWith decode
static member inline FromJson (_: Map<string, 'a>) = D.mapWith decode
static member inline FromJson (_: Result<'a, 'b>) = D.resultWith decode decode
static member inline FromJson (_: 'a * 'b) = D.tuple2With decode decode
static member inline FromJson (_: 'a * 'b * 'c) = D.tuple3With decode decode decode
static member inline FromJson (_: 'a * 'b * 'c * 'd) = D.tuple4With decode decode decode decode
static member inline FromJson (_: 'a * 'b * 'c * 'd * 'e) = D.tuple5With decode decode decode decode decode
static member inline FromJson (_: 'a * 'b * 'c * 'd * 'e * 'f) = D.tuple6With decode decode decode decode decode decode
static member inline FromJson (_: 'a * 'b * 'c * 'd * 'e * 'f * 'g) = D.tuple7With decode decode decode decode decode decode decode
module Json =
let inline decodeWithDefaults (defaults: ^def) (a: ^a): Decoder<Json,'a> =
Internal.decodeWithDefaults defaults a
let inline decode (json: Json) : JsonResult<'a>=
Internal.decode json
let inline encodeWithDefaults (defaults: ^def) (a: ^a): Json =
Internal.encodeWithDefaults defaults a
let inline encode (a: 'a) =
Internal.encode a
let inline deserialize (str: string) =
Json.parse str
|> JsonResult.bind decode
let inline serialize (a: 'a) =
encode a
|> Json.format
module Encode =
let inline requiredWithDefaults (defaults : ^def) (k : string) (v : ^a) (jObj : JsonObject) =
JsonObject.add k (Internal.encodeWithDefaults defaults v) jObj
let inline required k v (jObj : JsonObject) =
JsonObject.add k (Internal.encode v) jObj
let inline optionalWithDefaults (defaults : ^def) (k : string) (vO : ^a option) (jObj : JsonObject) =
match vO with
| Some v -> requiredWithDefaults defaults k v jObj
| None -> jObj
let inline optional k vO (jObj : JsonObject) =
match vO with
| Some v -> required k v jObj
| None -> jObj
let inline requiredMixin v jObj =
(^a : (static member Mixin: ^a * JsonObject -> JsonObject) (v, jObj))
let inline optionalMixin vO jObj =
match vO with
| Some v -> requiredMixin v jObj
| None -> jObj
module Decode =
let inline requiredWithDefaults (defaults : ^def) (k : string) : Decoder<JsonObject,'a> =
Json.Decode.required Internal.decode k
let inline required (k: string) : Decoder<JsonObject,'a> =
requiredWithDefaults Internal.ChironDefaults k
let inline optionalWithDefaults (defaults : ^def) (k : string) : Decoder<JsonObject,'a option> =
Json.Decode.optional Internal.decode k
let inline optional (k: string) : Decoder<JsonObject,'a option> =
optionalWithDefaults Internal.ChironDefaults k
let inline requiredMixin (json: Json): JsonResult<'a> =
(^a : (static member FromJson : ^a -> Decoder<Json,'a>) Unchecked.defaultof<'a>) json
[<AutoOpen>]
module Builders =
open JsonTransformer
type JsonBuilder () =
member __.Return (a : 'a) : Json<'a> = Json.init a
member __.ReturnFrom (aJ) : Json<'a> = aJ
member __.Bind (aJ, a2bJ) : Json<'a> = aJ |> Json.bind a2bJ
member __.Zero () : Json<unit> = Json.init ()
member __.Combine (m1, m2) : Json<'a> = m1 |> Json.bind (fun _ -> m2)
member __.Delay (u2bJ) : Json<'a> = Json.init () |> Json.bind u2bJ
type DecoderBuilder() =
member __.Return (a: 'a) : Decoder<JsonObject,'a> = Decoder.alwaysPass a
member __.ReturnFrom (aR: Decoder<JsonObject,'a>) = aR
member __.Bind (aM, a2bM) : Decoder<JsonObject,'a> = aM |> Decoder.bind a2bM
member __.Zero () : Decoder<JsonObject,unit> = Decoder.alwaysPass ()
member __.Combine(r1, r2) : Decoder<JsonObject,'a> = r1 |> Decoder.bind (fun _ -> r2)
member __.Delay(u2bM) : Decoder<JsonObject,'a> = Decoder.alwaysPass () |> Decoder.bind u2bM
member __.Run (aM : Decoder<JsonObject,'a>) : Decoder<Json,'a> =
Json.Decode.jsonObject |> Decoder.compose aM
let json = JsonBuilder ()
let jsonDecoder = DecoderBuilder()
[<AutoOpen>]
module Patterns =
let (|Object|Array|String|Number|Bool|Null|) = function
| Json.Object o -> Object o
| Json.Array a -> Array a
| Json.String s -> String s
| Json.Number n -> Number n
| Json.True -> Bool true
| Json.False -> Bool false
| Json.Null -> Null
let (|PropertyWith|_|) (r: Decoder<Json,'a>) (key: string) (json: Json) : 'a option =
Optics.get (Optics.Json.Property_ key) json
|> JsonResult.bind r
|> function
| JPass x -> Some x
| _ -> None
let inline (|Property|_|) (key: string) (json: Json): 'a option =
Optics.get (Optics.Json.Property_ key) json
|> JsonResult.bind Inference.Json.decode
|> function
| JPass x -> Some x
| _ -> None