json_transform.fs

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