Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
module JsonTransformer =
open System
open System.Globalization
open System.Text
type Json =
| Null
| Bool of bool
| Number of float
| String of string
| Array of Json []
| Object of (string*Json) []
let toString (json : Json) : string =
let sb = StringBuilder 16
let inline str (v : string) = sb.Append v |> ignore
let inline ch (v : char) = sb.Append v |> ignore
let inline estr (v : string) =
ch '"'
str v // TODO: Escape string
ch '"'
let rec loop j =
match j with
| Null -> str <| "null"
| Bool b -> str <| if b then "true" else "false"
| Number n -> str <| string n
| String s -> estr s
| Array vs ->
ch '['
aloop vs 0
ch ']'
| Object vs ->
ch '{'
oloop vs 0
ch '}'
and aloop vs i =
if i < vs.Length then
if i > 0 then
ch ','
let v = vs.[i]
loop v
aloop vs (i + 1)
and oloop vs i =
if i < vs.Length then
if i > 0 then
ch ','
let k, v = vs.[i]
estr k
ch ':'
loop v
oloop vs (i + 1)
loop json
sb.ToString ()
type JsonPathElement =
| Index of int
| Field of string
type JsonPath = JsonPathElement list
type JsonTransformError =
| NonCollection
| NonObject
| CanNotCoerceTo of Type
| IndexOutOfRange of int*int
| FieldNotFound of string
| NotValid of string
type JsonTransformErrorTree =
| Empty
| Leaf of JsonPath*JsonTransformError
| Fork of JsonTransformErrorTree*JsonTransformErrorTree
| Group of JsonPath*JsonTransformError []
| Many of JsonTransformErrorTree []
let (|IsEmpty|IsNotEmpty|) (e : JsonTransformErrorTree) =
match e with
| Empty -> IsEmpty
| Group (_ , vs) when vs.Length <= 0 -> IsEmpty
| Many vs when vs.Length <= 0 -> IsEmpty
| _ -> IsNotEmpty
let inline jresult v e = v, e
let inline jsuccess v = jresult v Empty
let inline jfailure v p e = jresult v <| Leaf (p, e)
module Internals =
let inline adapt f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt f
module Loop =
let jmany (t : OptimizedClosures.FSharpFunc<_, _, _>) p j m (vs : 'T []) =
let ra = ResizeArray vs.Length
let es = ResizeArray vs.Length
let rec loop i =
if i < vs.Length then
let v = vs.[i]
let tv, te = t.Invoke (Index i::p, m v)
ra.Add tv
match te with
| IsNotEmpty -> es.Add te
| IsEmpty -> ()
loop (i + 1)
loop 0
let e = if es.Count = 0 then Empty else Many <| es.ToArray ()
jresult (ra.ToArray ()) e
let join (l : JsonTransformErrorTree) (r : JsonTransformErrorTree) : JsonTransformErrorTree =
match l, r with
| IsEmpty , IsEmpty -> Empty
| IsEmpty , _ -> r
| _ , IsEmpty -> l
| _ , _ -> Fork (l ,r)
let collapse (e : JsonTransformErrorTree) : (JsonPath*JsonTransformError) [] =
let ra = ResizeArray 16
let rec loop ee =
match ee with
| Empty -> ()
| Leaf (p, e) -> ra.Add (p, e)
| Fork (l, r) -> loop l; loop r
| Group (p, es) -> for e in es do ra.Add (p, e)
| Many es -> for e in es do loop e
loop e
ra |> Seq.distinct |> Seq.toArray
open Internals
type JsonTransform<'T> =
{
Transform : JsonPath -> Json -> 'T*JsonTransformErrorTree
Default : unit -> 'T
}
let jdebug (name : string) (t : JsonTransform<'T>) : JsonTransform<'T> =
{
t with
Transform =
let tr = adapt t.Transform
fun p j ->
printfn "JSON_TRANSFORM: Before %s, p=%A, j=%A" name p j
let tv, te = tr.Invoke (p, j)
printfn "JSON_TRANSFORM: After %s, p=%A, j=%A, tv=%A, te=%A" name p j tv te
tv, te
}
let jrun (t : JsonTransform<'T>) (j : Json) : 'T*(JsonPath*JsonTransformError) []=
let tr = adapt t.Transform
let tv, te = tr.Invoke ([], j)
let te = collapse te
tv, te
// Monad
let jbind (t : JsonTransform<'T>) (uf : 'T -> JsonTransform<'U>) : JsonTransform<'U> =
{
Transform =
let tr = adapt t.Transform
fun p j ->
let tv, te = tr.Invoke (p, j)
let u = uf tv
let ur = adapt u.Transform
let uv, ue = ur.Invoke (p, j)
uv, (join te ue)
Default =
fun () ->
let tv = t.Default ()
let u = uf tv
u.Default ()
}
let inline (>>=) t uf = jbind t uf
let jreturn v : JsonTransform<'T> =
{
Transform = fun p j -> jsuccess v
Default = fun () -> v
}
// Functor
let jmap (m : 'T -> 'U) (t : JsonTransform<'T>) : JsonTransform<'U> =
t >>= (m >> jreturn)
let inline (>>!) t m = jmap m t
// Applicative
let inline jpure v = jreturn v
let japply (f : JsonTransform<'T -> 'U>) (t : JsonTransform<'T>) : JsonTransform<'U> =
f >>= fun ff -> t >>! ff
let inline (<*>) f t = japply f t
// Kleisli
let jarr f : 'T -> JsonTransform<'U> = f >> jreturn
let jkleisli (tf : _ -> JsonTransform<'T>) (uf : 'T -> JsonTransform<'U>) : _ -> JsonTransform<'U> =
fun v -> (tf v) >>= uf
let inline (>=>) tf uf = jkleisli tf uf
// Misc
let jvalidate (validate : 'T -> JsonTransformError []) (t : JsonTransform<'T>) : JsonTransform<'T> =
{ t with
Transform =
let tr = adapt t.Transform
fun p j ->
let tv, te = tr.Invoke (p, j)
let es = validate tv
if es.Length = 0 then
jresult tv te
else if es.Length = 1 then
jresult tv <| join te (Leaf (p, es.[0]))
else
jresult tv <| join te (Group (p, es))
}
let jcheck (validate : 'T -> bool) (e : string) (t : JsonTransform<'T>) : JsonTransform<'T> =
let es = [|NotValid e|]
let vv v =
if validate v then Array.empty
else es
jvalidate vv t
let jorElse (l : JsonTransform<'T>) (r : JsonTransform<'T>) : JsonTransform<'T> =
{ r with
Transform =
let lr = adapt l.Transform
let rr = adapt r.Transform
fun p j ->
let lv, le = lr.Invoke (p, j)
match le with
| IsEmpty -> jsuccess lv
| _ ->
let rv, re = rr.Invoke (p, j)
match re with
| IsEmpty -> jsuccess rv
| _ -> jresult rv <| join le re
}
let inline (<|>) l r = jorElse l r
let jdefault l r = l <|> (jreturn r)
let inline (<|>!) l r = jdefault l r
let inline jleft t u = t >>= fun v -> u >>= fun _ -> jreturn v
let inline (.>>) t u = jleft u
let inline jright t u = t >>= fun _ -> u
let inline (>>.) t u = jright t u
type JsonTransformBuilder() =
member x.Bind (t, uf) = jbind t uf
member x.Return v = jreturn v
member x.ReturnFrom t = t
let jtransform = JsonTransformBuilder ()
// Query
type NavigateResult<'T> =
| NavigateTo of JsonPath*Json
| NavigateValue of 'T
| NavigateError of JsonTransformError
let jnavigate (navigator: JsonPath -> Json -> NavigateResult<'T>) (t : JsonTransform<'T>) : JsonTransform<'T> =
{ t with
Transform =
let tr = adapt t.Transform
let na = adapt navigator
fun p j ->
match na.Invoke (p, j) with
| NavigateTo (np, nj) -> tr.Invoke (np, nj)
| NavigateValue v -> jsuccess v
| NavigateError e ->
jfailure (t.Default ()) p e
}
let jfield (name : string) (t : JsonTransform<'T>) : JsonTransform<'T> =
let rescope p j =
match j with
| Null
| Bool _
| Number _
| String _
| Array _ ->
NavigateError NonObject
| Object vs->
match vs |> Array.tryFind (fst >> (=) name) with
| Some (_, v) ->
NavigateTo (Field name::p, v)
| _ ->
NavigateError <| FieldNotFound name
jnavigate rescope t
let jindex (idx : int) (t : JsonTransform<'T>) : JsonTransform<'T> =
let rescope p j =
match j with
| Null
| Bool _
| Number _
| String _ ->
NavigateError NonCollection
| Array vs when idx >= 0 && idx < vs.Length ->
let v = vs.[idx]
NavigateTo (Index idx::p, v)
| Array vs ->
NavigateError <| IndexOutOfRange (idx, vs.Length)
| Object vs when idx >= 0 && idx < vs.Length ->
let _, v = vs.[idx]
NavigateTo (Index idx::p, v)
| Object vs ->
NavigateError <| IndexOutOfRange (idx, vs.Length)
jnavigate rescope t
let jofield (name : string) dv (t : JsonTransform<'T>) : JsonTransform<'T> =
let rescope p j =
match j with
| Null
| Bool _
| Number _
| String _
| Array _ ->
NavigateError NonObject
| Object vs->
match vs |> Array.tryFind (fst >> (=) name) with
| Some (_, v) ->
NavigateTo (Field name::p, v)
| _ ->
NavigateValue dv
jnavigate rescope t
let inline jthis t = t
let inline (?) t n = jfield n >> t
let inline (@) t n = jindex n >> t
let jmany (t : JsonTransform<'T>) : JsonTransform<'T []> =
{
Transform =
let tr = adapt t.Transform
fun p j ->
match j with
| Null
| Bool _
| Number _
| String _ -> jfailure Array.empty p NonCollection
| Array vs -> Loop.jmany tr p j id vs
| Object vs -> Loop.jmany tr p j snd vs
Default = fun () -> Array.empty
}
let jcoerce dv (c : Json -> 'T option) : JsonTransform<'T> =
{
Transform =
fun p j ->
match c j with
| Some v -> jsuccess v
| None -> jfailure dv p <| CanNotCoerceTo typeof<'T>
Default = fun () -> dv
}
let jstring : JsonTransform<string> =
jcoerce "" <| function
| Null -> Some <| ""
| Bool b -> Some <| if b then "true" else "false"
| Number n -> Some <| string n
| String s -> Some <| s
| Array _
| Object _ -> None
let jfloat : JsonTransform<float> =
jcoerce 0. <| function
| Null -> Some <| 0.
| Bool b -> Some <| if b then 1. else 0.
| Number n -> Some <| n
| String s ->
let b, v = Double.TryParse (s, NumberStyles.Float, CultureInfo.InvariantCulture)
if b then Some v
else None
| Array _
| Object _ -> None
module Test =
open JsonTransformer
type Person =
{
Id : string
FirstName : string
LastName : string
}
static member New id fn ln : Person = { Id = id; FirstName = fn; LastName = ln }
type Company =
{
Id : string
Name : string
CompanyNo : string
TaxNo : string
}
static member New id nm cno tno : Company = { Id = id; Name = nm; CompanyNo = cno; TaxNo = tno }
type Customer =
| Person of Person
| Company of Company
type OrderRow =
{
Product : string
Quantity : float // TODO: Use decimal
}
static member New p q : OrderRow = { Product = p; Quantity = q }
type Order =
{
Id : string
CustomerId : string
Rows : OrderRow []
}
static member New id cid rows : Order = { Id = id; CustomerId = cid; Rows = rows }
type Full =
{
Customers : Customer []
Orders : Order []
}
static member New cs os : Full = { Customers = cs; Orders = os }
let inline jstr n = jstring |> jfield n
let inline jqty n = jfloat |> jcheck ((<) 0.) "Quantity must be positive" |> jofield n 1.
let jperson =
jpure Person.New
<*> jstr "id"
<*> jstr "firstName"
<*> jstr "lastName"
>>! Person
let jpersons = jmany jperson
let jcompany =
jpure Company.New
<*> jstr "id"
<*> jstr "name"
<*> jstr "companyNo"
<*> jstr "taxNo"
>>! Company
let jcompanies = jmany jcompany
let jcustomer = jperson <|> jcompany
let jcustomers = jmany jcustomer
let jorderRow =
jpure OrderRow.New
<*> jstr "product"
<*> jqty "quantity"
let jorderRows = jmany jorderRow
let jorder =
jpure Order.New
<*> jstr "id"
<*> jstr "customerId"
<*> jthis?rows jorderRows
let jorders = jmany jorder
let jfull =
jtransform {
let! customers = jthis?customers jcustomers
let! orders = jthis?orders jorders
return Full.New customers orders
}
let json =
let person id fn ln =
Object
[|
"id" , String (string id)
"firstName" , String fn
"lastName" , String ln
|]
let company id nm cno tno =
Object
[|
"id" , String (string id)
"name" , String nm
"companyNo" , String cno
"taxNo" , String tno
|]
let order id cid rows =
Object
[|
"id" , String (string id)
"customerId" , String (string cid)
"rows" , Array rows
|]
let orderRow p q =
Object
[|
"product" , String p
"quantity" , String (string q)
|]
let full cs os =
Object
[|
"customers" , Array cs
"orders" , Array os
|]
full
[|
// Customers
person 1 "Bill" "Gates"
person 2 "Melinda" "Gates"
company 3 "Microsoft" "123" "MVAXYZ"
|]
[|
// Orders
order 1 1 [| orderRow "Silver Tape" 1; orderRow "Milk" 2 |]
order 2 2 [| orderRow "Handbag" -1 |]
|]
open Test
[<EntryPoint>]
let main argv =
let full, errors = JsonTransformer.jrun jfull json
// printfn "JSON: %A" <| JsonTransformer.toString json
printfn "Errors: %A" <| errors
printfn "%A" <| full
0
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment