transformer.fs

module AnyTransformer =
  type [<AbstractClass>] BadCause () =
    class
      abstract Describe : string
      override x.ToString () = x.Describe
    end

  type [<Sealed>] MessageBadCause (msg: string) =
    class
      inherit BadCause ()
      let describe = sprintf "Message: %s" msg
      override x.Describe = describe
    end

  type [<Sealed>] NoMemberBadCause (name: string) =
    class
      inherit BadCause ()
      let describe = sprintf "NoMember: %s" name
      override x.Describe = describe
    end

  type [<Sealed>] OutOfRangeBadCause (index: int) =
    class
      inherit BadCause ()
      let describe = sprintf "OutOfRange: %d" index
      override x.Describe = describe
    end

  type [<Sealed>] NotAssociativeBadCause () =
    class
      inherit BadCause ()
      let describe = sprintf "NotAssociative"
      override x.Describe = describe
    end

  type [<Sealed>] NotIndexableBadCause () =
    class
      inherit BadCause ()
      let describe = sprintf "NotIndexable"
      override x.Describe = describe
    end

  type [<Sealed>] ExceptionBadCause (exc : exn) =
    class
      inherit BadCause ()
      let describe = sprintf "Exception: %s" exc.Message
      override x.Describe = describe
    end

  type [<Sealed>] AnyBadCause (any : obj) =
    class
      inherit BadCause ()
      let describe = sprintf "Any: %A" any
      override x.Describe = describe
    end

  [<RequireQualifiedAccess>]
  type PathPart = 
    | Member  of string
    | Index   of int
    | Named   of string

  type Path = PathPart list

  [<RequireQualifiedAccess>]
  type BadTree =
    | Empty
    | Leaf      of Path*BadCause
    | Fork      of BadTree*BadTree
    | Suppress  of BadTree

  type TransformContext =
    {
      Lookup    : obj -> string -> Result<obj, BadCause>
      Index     : obj -> int    -> Result<obj, BadCause>
      Indexer   : obj           -> Result<int*(int -> obj), BadCause>
    }

    static member Default : TransformContext =
      let lookup (any : obj) name : Result<obj, BadCause> =
        match any with
        | :? System.Collections.IDictionary as dic ->
          if dic.Contains name then
            Ok (dic.[name])
          else
            Error (upcast NoMemberBadCause name)
        | _ -> 
          Error (upcast NotAssociativeBadCause ())

      let index (any : obj) idx : Result<obj, BadCause> =
        if idx < 0 then
          Error (upcast OutOfRangeBadCause idx)
        else
          match any with
          | :? System.Collections.IList as lis ->
            if idx < lis.Count then
              Ok (lis.[idx])
            else
              Error (upcast OutOfRangeBadCause idx)
          | :? System.Collections.IEnumerable as enu ->
            let e = enu.GetEnumerator ()
            let rec loop (e : System.Collections.IEnumerator) i : Result<obj, BadCause> =
              if e.MoveNext () then
                if i > 0 then
                  loop e (i - 1)
                else
                  Ok e.Current
              else
                Error (upcast OutOfRangeBadCause idx)
            loop e idx
          | _ -> 
            Error (upcast NotIndexableBadCause ())

      let indexer (any : obj) : Result<int*(int -> obj), BadCause> =
        match any with
        | :? System.Collections.IList as lis ->
          let ra = ResizeArray lis.Count
          for i = 0 to (lis.Count - 1) do
            ra.Add (lis.[i])
          Ok (lis.Count, fun idx -> lis.[idx])
        | :? System.Collections.IEnumerable as enu ->
          let ra = ResizeArray 16
          let e = enu.GetEnumerator ()
          while e.MoveNext () do
            ra.Add e.Current
          Ok (ra.Count, fun idx -> ra.[idx])
        | _ -> 
          Error (upcast NotIndexableBadCause ())

      {
        Lookup    = lookup
        Index     = index
        Indexer   = indexer
      }

  type [<Struct>] TransformResult<'T> = TR of 'T*BadTree

  type [<Struct>] Transform<'T> = T of (TransformContext -> Path -> obj -> TransformResult<'T>)

  [<RequireQualifiedAccess>]
  type TransformedValue<'T> =
    | IsGood          of 'T
    | WithWarnings    of 'T*struct (string*BadCause) []
    | WithErrors      of 'T*struct (string*BadCause) []*struct (string*BadCause) []

  module Transform =
    open FSharp.Core.Printf

    open System

    module Details =
      open System.Text

      let defaultSize = 16

      let inline adapt (T t) = OptimizedClosures.FSharpFunc<_, _, _, _>.Adapt t

      let inline invoke (f : OptimizedClosures.FSharpFunc<_, _, _, _>) a b c = f.Invoke (a, b, c)

      let inline btjoin l r =
        match (l, r) with
        | BadTree.Empty     ,  _                  -> r
        | _                 ,  BadTree.Empty      -> l
        | BadTree.Suppress l,  BadTree.Suppress r -> BadTree.Suppress (BadTree.Fork (l, r))
        | _                 ,  _                  -> BadTree.Fork (l, r)

      let inline btisgood t =
        match t with
        | BadTree.Empty
        | BadTree.Suppress _    -> true
        | _                     -> false

      let inline btsuppress t =
        match t with
        | BadTree.Empty
        | BadTree.Suppress _    -> t
        | _                     -> BadTree.Suppress t

      let inline btleaf ctx bc = BadTree.Leaf (ctx, bc)

      let inline tresult v bt = TR (v, bt)

      let inline one  () = LanguagePrimitives.GenericOne<'T>

      let inline zero () = LanguagePrimitives.GenericZero<'T>

      module Loops =
        let rec bcpath (sb : StringBuilder) bc =
          let inline app t = sb.Append (t : string) |> ignore
          match bc with
          | []    -> app "root"
          | h::t  ->
            bcpath sb t
            match h with
            | PathPart.Member m -> app (sprintf ".%s" m)
            | PathPart.Index  i -> app (sprintf ".[%d]" i)
            | PathPart.Named  n -> app (sprintf "(%s)" n)

        let rec btcollapse (es : ResizeArray<_>) (ws : ResizeArray<_>) s t =
          match t with
          | BadTree.Empty               -> ()
          | BadTree.Leaf      (cs, bc)  ->
            let sb = StringBuilder defaultSize
            bcpath sb cs
            let ra = if s then ws else es
            ra.Add <| struct (sb.ToString (), bc)
          | BadTree.Fork      (l , r)   -> btcollapse es ws s l; btcollapse es ws s r
          | BadTree.Suppress  t         -> btcollapse es ws true t

        let rec tchoose bv (cs : _ []) ctx path any cbc i =
          if i < cs.Length then
            let s, t = cs.[i]
            let (TR (_, sbc)) = invoke s ctx path any
            if btisgood sbc then
              invoke t ctx path any
            else
              tchoose bv cs ctx path any (btjoin cbc sbc) (i + 1)
          else
            tresult bv cbc

        let rec tmany t ctx path indexer c (ra : ResizeArray<_>) cbc i =
          if i < c then
            let nany  = indexer i
            let npath = (PathPart.Index i)::path
            let (TR (tv, tbc)) = invoke t ctx npath nany
            ra.Add tv
            tmany t ctx path indexer c ra (btjoin cbc tbc) (i + 1)
          else
            cbc

    open Details
    open System.Globalization

    let inline tgood    v       = tresult v BadTree.Empty
    let inline tleaf    ctx bc  = btleaf ctx bc

    let inline treturn v =
      T <| fun _ _ _ ->
        tgood v

    let inline tbad bv bc =
      T <| fun _ path _ ->
        tresult bv (tleaf path bc)

    let inline tfailwith    bv msg  = tbad bv (MessageBadCause msg)
    let inline tfailwithf   bv fmt  = kprintf (tfailwith) fmt

    let inline tfailwithz   msg     = tfailwith  (zero ())  msg
    let inline tfailwithzf  fmt     = kprintf tfailwithz fmt

    let inline tone  () = treturn (one ())
    let inline tzero () = treturn (zero ())

    // Combinators

    let inline tbind t uf =
      let t = adapt t
      T <| fun ctx path any ->
        let (TR (tv, tbc)) = invoke t ctx path any
        let u              = uf tv
        let u              = adapt u
        let (TR (uv, ubc)) = invoke u ctx path any
        tresult uv (btjoin tbc ubc)

    // Applicative apply

    let inline tapply f t =
      let f = adapt f
      let t = adapt t
      T <| fun ctx path any ->
        let (TR (fv, fbc)) = invoke f ctx path any
        let (TR (tv, tbc)) = invoke t ctx path any
        tresult (fv tv) (btjoin fbc tbc)

    // Functor map

    let inline tmap m t =
      let t = adapt t
      T <| fun ctx path any ->
        let (TR (tv, tbc)) = invoke t ctx path any
        tresult (m tv) tbc

    // Combinators

    let inline tand l r =
      let l = adapt l
      let r = adapt r
      T <| fun ctx path any ->
        let (TR (lv, lbc)) = invoke l ctx path any
        let (TR (rv, rbc)) = invoke r ctx path any
        tresult (lv, rv) (btjoin lbc rbc)

    let inline tor l r =
      let l = adapt l
      let r = adapt r
      T <| fun ctx path any ->
        let (TR (lv, lbc)) = invoke l ctx path any
        let (TR (rv, rbc)) = invoke r ctx path any
        if btisgood lbc then
          tresult lv (btjoin lbc (btsuppress rbc))
        else
          let (TR (rv, rbc)) = invoke r ctx path any
          if btisgood rbc then
            tresult rv (btjoin (btsuppress lbc) rbc)
          else
            tresult rv (btjoin lbc rbc)

    let inline torElse l r =
      let l = adapt l
      let r = adapt r
      T <| fun ctx path any ->
        let (TR (lv, lbc)) = invoke l ctx path any
        if btisgood lbc then
          tresult lv lbc
        else
          let (TR (rv, rbc)) = invoke r ctx path any
          if btisgood rbc then
            tresult rv (btjoin (btsuppress lbc) rbc)
          else
            tresult rv (btjoin lbc rbc)

    let inline tcheck c bv t =
      let c = adapt c
      let t = adapt t
      T <| fun ctx path any ->
        let (TR (_, cbc)) = invoke c ctx path any
        if btisgood cbc then
          let (TR (tv, tbc)) = invoke t ctx path any
          tresult tv (btjoin cbc tbc)
        else
          tresult bv cbc

    let inline tcheckz c t = tcheck c (zero ()) t

    let inline tchoose bv cs =
      let cs = Array.map (fun (s, t) -> adapt s, adapt t) cs
      T <| fun ctx path any ->
        Loops.tchoose bv cs ctx path any BadTree.Empty 0

    let inline tchoosez cs = tchoose (zero ()) cs

    let inline tjoin t =
      let t = adapt t
      T <| fun ctx path any ->
        let (TR (tv, tbc)) = invoke t ctx path any
        let tv             = adapt tv
        let (TR (ttv, ubc))= invoke tv ctx path any
        tresult ttv (btjoin tbc ubc)

    let inline topt t =
      let t = adapt t
      T <| fun ctx path any ->
        let (TR (tv, tbc)) as tr = invoke t ctx path any
        if btisgood tbc then
          tresult (Some tv) tbc
        else
          tresult None (BadTree.Suppress tbc)

    let inline tsuppress t =
      let t = adapt t
      T <| fun ctx path any ->
        let (TR (tv, tbc)) as tr = invoke t ctx path any
        if btisgood tbc then
          tr
        else
          tresult tv (BadTree.Suppress tbc)

    let inline tverify (v : 'T -> #BadCause option) t =
      let t = adapt t
      T <| fun ctx path any ->
        let (TR (tv, tbc)) as tr = invoke t ctx path any
        match v tv with
        | Some bc ->
          let bc = bc |> btleaf path
          tresult tv (btjoin tbc bc)
        | None ->
          tr

    // Extractors

    let tisNull =
      T <| fun ctx path any ->
        let tv = isNull any
        tgood tv

    let inline tasDateTime (formats : string []) =
      T <| fun ctx path any ->
        match any with
        | null                -> tgood DateTime.MinValue
        | :? DateTime as tdt  -> tgood tdt
        | _             -> 
          let ts      = any.ToString ()
          let tb, tdt = DateTime.TryParseExact (ts, formats, CultureInfo.InvariantCulture, DateTimeStyles.AssumeUniversal)
          if tb then
            tgood tdt
          else
            tresult DateTime.MinValue (MessageBadCause "Can't interpret value as as a datetime" |> btleaf path)

    let tasInt =
      T <| fun ctx path any ->
        match any with
        | null          -> tgood 0
        | :? int as ti  -> tgood ti
        | _             -> 
          let ts      = any.ToString ()
          let tb, ti  = Int32.TryParse ts
          if tb then
            tgood ti
          else
            tresult 0 (MessageBadCause "Can't interpret value as a number" |> btleaf path)

    let tasString =
      T <| fun ctx path any ->
        let tv = if isNull any then "" else any.ToString ()
        tgood tv

    // Navigators

    let inline tindex idx bv t =
      let t = adapt t
      T <| fun ctx path any ->
        match ctx.Index any idx with
        | Ok nany ->
          let npath = (PathPart.Index idx)::path
          invoke t ctx npath nany
        | Error bc -> 
          tresult bv (bc |> btleaf path)

    let inline tindexz idx t = tindex idx (zero ()) t

    let inline tmany t =
      let t = adapt t
      T <| fun ctx path any ->
        match ctx.Indexer any with
        | Ok (c, indexer) ->
          let ra  = ResizeArray 16
          let lbc = Loops.tmany t ctx path indexer c ra BadTree.Empty 0
          tresult (ra.ToArray ()) lbc
        | Error bc -> 
          tresult [||] (bc |> btleaf path)

    let inline tmember name bv t =
      let t = adapt t
      T <| fun ctx path any ->
        match ctx.Lookup any name with
        | Ok nany ->
          let npath = (PathPart.Member name)::path
          invoke t ctx npath nany
        | Error bc -> 
          tresult bv (bc |> btleaf path)

    let inline tmemberz name t = tmember name (zero ()) t

    // Misc

    let inline tdebug nm t =
      let t = adapt t
      T <| fun ctx path any ->
        printfn "BEFORE - %s - %A - %A" nm path any
        let tr = invoke t ctx path any
        printfn "AFTER - %s - %A - %A - %A" nm path any tr
        tr

    let trun ctx any t =
      let t   = adapt t
      let (TR (tv, tbc)) = invoke t ctx [] any

      let es = ResizeArray defaultSize
      let ws = ResizeArray defaultSize
      Loops.btcollapse es ws false tbc

      if es.Count = 0 && ws.Count = 0 then
        TransformedValue.IsGood tv
      elif es.Count = 0 then
        TransformedValue.WithWarnings (tv, ws.ToArray ())
      else
        TransformedValue.WithErrors (tv, es.ToArray (), ws.ToArray ())

    type Builder () =
      member inline x.Bind        (t, uf) = tbind t uf
      member inline x.Return      v       = treturn v
      member inline x.ReturnFrom  t       = t : Transform<_>
      member inline x.Zero        ()      = tzero

  type Transform<'T> with
    static member inline (>>=)  (t, uf) = Transform.tbind   t uf
    static member inline (<*>)  (f, t)  = Transform.tapply  f t
    static member inline (<&>)  (l, r)  = Transform.tand    l r
    static member inline (<|>)  (l, r)  = Transform.tor     l r
    static member inline (<||>) (l, r)  = Transform.torElse l r
    static member inline (|>>)  (t, m)  = Transform.tmap    m t

  let transform = Transform.Builder ()

open AnyTransformer
open Newtonsoft.Json.Linq

let jsonContext = 
  let ctx = TransformContext.Default

  let lookup (any : obj) name : Result<obj, BadCause> =
    match any with
    | :? JObject as jobj ->
      let b, v = jobj.TryGetValue name
      if b then
        Ok (upcast v)
      else
        Error (upcast NoMemberBadCause name)
    | _ -> 
      ctx.Lookup any name

  let index (any : obj) idx : Result<obj, BadCause> =
    match any with
    | :? JArray as jarr ->
      if idx >= 0 && idx < jarr.Count then
        Ok (upcast jarr.[idx])
      else
        Error (upcast OutOfRangeBadCause idx)
    | _ -> 
      ctx.Index any idx

  let indexer (any : obj) : Result<int*(int -> obj), BadCause> =
    match any with
    | :? JArray as jarr ->
      Ok (jarr.Count, fun idx -> upcast jarr.[idx])
    | _ -> 
      ctx.Indexer any

  { ctx with Lookup = lookup; Index = index; Indexer = indexer }

module Test =
  open System
  open System.Collections.Generic
  open Newtonsoft.Json.Linq


  type Customer =
    {
      Id        : int
      FirstName : string
      LastName  : string
    }

    static member New id firstName lastName = {Id = id; FirstName = firstName; LastName = lastName}

  type OrderLine =
    {
      LineNo      : int
      Product     : string
      Quantity    : int
      Amount      : int
    }

    static member New lineNo product quantity amount = {LineNo = lineNo; Product = product; Quantity = quantity; Amount = amount}

  type Order =
    {
      Id          : int
      CustomerId  : int
      Amount      : int
      Currency    : string
      Lines       : OrderLine []
    }

    static member New id customerId amount currency lines = {Id = id; CustomerId = customerId; Amount = amount; Currency = currency; Lines = lines}

  [<RequireQualifiedAccess>]
  type Request =
    | NewCustomer  of Customer
    | NewOrder     of Order
    | Unknown
    static member Zero = Unknown

  type Envelope = Envelope of string*DateTime*Request

  open AnyTransformer.Transform

  let tintMember nm   = tmemberz  nm              tasInt
  let tstrMember nm   = tmember   nm ""           tasString
  let tdtMember  nm   = tmember   nm DateTime.Now (tasDateTime [|"yyyy-MM-dd"|])

  let tcustomer =
    treturn Customer.New
    <*> tintMember "id"
    <*> tstrMember "firstName"
    <*> tstrMember "lastName"
    |>> Request.NewCustomer

  let torderLine =
    treturn OrderLine.New
    <*> tintMember "lineNo"
    <*> tstrMember "product"
    <*> tintMember "quantity"
    <*> tintMember "amount"
  let torderLines = tmany torderLine

  let torder =
    treturn Order.New
    <*> tintMember "id"
    <*> tintMember "customerId"
    <*> tintMember "amount"
    <*> tstrMember "currency"
    <*> tmember    "lines" [||] torderLines
    |>> Request.NewOrder

  let trequest = 
    let req s t = 
      let tf = sprintf "@schema expected to be %s" s |> MessageBadCause |> Some
      let f v= if v = s then None else tf
      let tc = tmember "@schema" "" (tverify f tasString)
      tc, tmemberz "request" t
    [|
      req "customer" tcustomer
      req "order"    torder
    |] |> tchoosez

  let tenvelope =
    treturn (fun mid ts req -> Envelope (mid, ts, req))
    <*> tstrMember "messageId"
    <*> tdtMember  "timestamp"
    <*> trequest

  let dict (kvs : _ []) = 
    let d = Dictionary<_, _> ()
    for k, v in kvs do
      d.[k] <- v
    box d

  let customer =
    [|
      "messageId"     , box "uuid0001"
      "timestamp"     , box DateTime.Now
      "@schema"       , box "customer"
      "request"       , 
        [|
          "id"          , box 1001
          "firstName"   , box "Bill"
          "lastName"    , box "Gates"
        |] |> dict
    |] |> dict

  let order =
    [|
      "messageId"   , box "uuid0001"
      "timestamp"   , box DateTime.Now
      "@schema"     , box "order"
      "request"     , 
        [|
          "id"          , box 1001
          "customerId"  , box "1001"
          "amount"      , box 100
          "currency"    , box "SEK"
          "lines"       ,
            [|
              [|
                "lineNo"      , box 1
                "product"     , box "Fussball"
                "quantity"    , box 20
                "amount"      , box "100"
              |] |> dict
              [|
                "lineNo"      , box 2
                "product"     , box "Tamagochi"
                "quantity"    , box 10
                "amount"      , box 150
              |] |> dict
            |] |> box
        |] |> dict
    |] |> dict

  let orderJson = """{
      "messageId"   : "uuid0001"
    , "timestamp"   : "2017-01-01"
    , "@schema"     : "order"
    , "request"     : {
        "id"          : 1001
      , "customerId"  : "1001"
      , "amount"      : 100
      , "currency"    : "SEK"
      , "lines"       : [
          {
              "lineNo"    : 1
            , "product"   : "Fussball"
            , "quantity"  : 20
            , "amount"    : "100"
          }
        , {
              "lineNo"    : 2
            , "product"   : "Tamagochi"
            , "quantity"  : 10
            , "amount"    : 150
          }
      ]
    }
  }
  """

  let transformDictionaries () =
    let ctx = TransformContext.Default
    Transform.trun ctx customer tenvelope |> printfn "%A"
    Transform.trun ctx order    tenvelope |> printfn "%A"

  let transformJson () =
    let parsedOrder = Newtonsoft.Json.JsonConvert.DeserializeObject<JObject> orderJson

    let ctx = TransformContext.Default
    Transform.trun ctx parsedOrder tenvelope |> printfn "%A"
    Transform.trun jsonContext parsedOrder tenvelope |> printfn "%A"

module Versioned =
  open System
  open System.Collections.Generic
  open Newtonsoft.Json.Linq

  open AnyTransformer

  let json = """
[
    {
        "name"      : "Cosmo Cramer"
      , "password"  : "12345"
      , "socialNo"  : "ABC-98765"
      , "comment"   : "Original version"
    }
  , {
        "firstName" : "Jerry"
      , "lastName"  : "Seinfeld"
      , "password"  : "12345"
      , "comment"   : "Realized we should split first and last name"
    }
  , {
        "@schema"   : "Customer"
      , "@version"  : 1
      , "firstName" : "George"
      , "lastName"  : "Constanza"
      , "hash"      : "==<<>>=="
      , "socialNo"  : "ABC-98765"
      , "comment"   : "Introduced major version"
    }
  , {
        "@schema"   : "Customer"
      , "@version"  : 2
      , "id"        : "ID_1001"
      , "firstName" : "Elaine"
      , "lastName"  : "Benes"
      , "birthDate" : "1974-01-01"
      , "hash"      : "==<<>>=="
      , "socialNo"  : "ABC-98765"
      , "comment"   : "Major version 2 added ID and birthdate"
    }
  , {
        "@schema"   : "Customer"
      , "@version"  : 3
      , "id"        : "ID_1001"
      , "firstName" : "Elaine"
      , "lastName"  : "Benes"
      , "birthDate" : "1974-01-01"
      , "hash"      : "==<<>>=="
      , "socialNo"  : "ABC-98765"
      , "comment"   : "Major version 3 just to test invalid versions"
    }
]"""

  type Customer =
    {
      Version     : int
      Id          : string
      Hash        : string
      FirstName   : string
      LastName    : string
      BirthDate   : DateTime option
      SocialNo    : string option
    }

    static member New v i h f l b s : Customer =
      {
        Version   = v
        Id        = i
        Hash      = h
        FirstName = f
        LastName  = l
        BirthDate = b
        SocialNo  = s
      }

    static member Zero = Customer.New 0 "" "" "" "" None None

  open Transform
  
  let tintMember nm   = tmemberz  nm              tasInt
  let tstrMember nm   = tmember   nm ""           tasString
  let tdtMember  nm   = tmember   nm DateTime.Now (tasDateTime [|"yyyy-MM-dd"|])

  module Approach1 =
    let tnamePair     =
      let tfirstName  = tstrMember  "firstName"
      let tlastName   = tstrMember  "lastName"
      let tname       = tstrMember  "name"
      (tfirstName <&> tlastName) <|> (tname |>> (fun fullName -> 
        match fullName.Split ' ' with
        | [||]  -> ""     , ""
        | [|n|] -> ""     , n
        | ns    -> ns.[0] , ns.[1]))

    let hashPwd s   = s |> hash |> string

    let tversion    = tintMember  "@version" <|> treturn 0
    let tid         = tstrMember  "id" <|> (tnamePair |>> fun (fn, ln) -> sprintf "%s/%s" ln fn)
    let thash       = tstrMember  "hash" <|> (tstrMember "password" |>> hashPwd)
    let tfirstName  = tnamePair   |>> fst
    let tlastName   = tnamePair   |>> snd
    let tbirthDate  = tdtMember   "birthDate" |> topt
    let tsocialNo   = tstrMember  "socialNo"  |> topt

    let tcustomer   = 
      treturn Customer.New
      <*> tversion
      <*> tid
      <*> thash
      <*> tfirstName
      <*> tlastName
      <*> tbirthDate
      <*> tsocialNo

    let tcustomers = tmany tcustomer

  module Approach2 =
    let genId fn ln = sprintf "%s/%s" ln fn
    let hashPwd s   = s |> hash |> string

    let tversion    = tintMember  "@version" <|> treturn 0
    let tid_v1      = (tstrMember  "firstName" <&> tstrMember  "lastName") |>> fun (fn, ln) -> genId fn ln
    let tid         = tstrMember  "id"
    let tfirstName  = tstrMember  "firstName"
    let tlastName   = tstrMember  "lastName"
    let tname       = tstrMember  "name"
    let thash       = tstrMember  "hash" 
    let tpassword   = tstrMember  "password" |>> hashPwd
    let tbirthDate  = tdtMember   "birthDate" |> topt
    let tsocialNo   = tstrMember  "socialNo"  |> topt

    let tcustomer_b v id fn ln =
      treturn Customer.New
      <*> treturn v     // Version   
      <*> treturn id    // Id        
      <*> tpassword     // Hash      
      <*> treturn fn    // FirstName 
      <*> treturn ln    // LastName  
      <*> treturn None  // BirthDate 
      <*> tsocialNo     // SocialNo  

    // Transforms a beta1 customer
    let tcustomer_b1  = 
      transform {
        let! name = tname
        let fn, ln= 
          match name.Split ' ' with
          | [||]  -> ""     , ""
          | [|n|] -> ""     , n
          | ns    -> ns.[0] , ns.[1]
        let id    = genId fn ln
        return! tcustomer_b -1 id fn ln
      }

    // Transforms a beta2 customer
    let tcustomer_b2  = 
      treturn tcustomer_b
      <*> treturn -2
      <*> tid_v1
      <*> tfirstName
      <*> tlastName
      |> tjoin

    // Transforms a v1 customer
    let tcustomer_v1  = 
      treturn Customer.New
      <*> tversion      // Version   
      <*> tid_v1        // Id        
      <*> thash         // Hash      
      <*> tfirstName    // FirstName 
      <*> tlastName     // LastName  
      <*> treturn None  // BirthDate 
      <*> tsocialNo     // SocialNo  

    // Transforms a v2 customer
    let tcustomer_v2  = 
      treturn Customer.New
      <*> tversion      // Version   
      <*> tid           // Id        
      <*> thash         // Hash      
      <*> tfirstName    // FirstName 
      <*> tlastName     // LastName  
      <*> tbirthDate    // BirthDate 
      <*> tsocialNo     // SocialNo  
   
    let tcustomer =
      let version v t = 
        let tf = sprintf "@version expected to be %d" v |> MessageBadCause |> Some
        let f x= if v = x then None else tf
        let tc = tmember "@version" 0 (tverify f tasInt) |>> ignore
        tc, t
      let invalidVersion = 
        let tc = tmember "@version" "" tasString |>> ignore
        tc, tfailwith Customer.Zero "Invalid @version"
      [|
        version 2 tcustomer_v2          // if @version=2 tag exists
        version 1 tcustomer_v1          // if @version=1 tag exists
        invalidVersion                  // Swallows all unrecognized versions
        tname |>> ignore, tcustomer_b1  // Detects unversion beta 1 schema
        treturn ()      , tcustomer_b2  // Assumes all other unversioned to be beta 2 schema
      |] |> tchoosez


    let tcustomers = tmany tcustomer

  let transform () =
    let parsed = Newtonsoft.Json.JsonConvert.DeserializeObject<JArray> json

    Transform.trun jsonContext parsed Approach1.tcustomers |> printfn "%A"
    Transform.trun jsonContext parsed Approach2.tcustomers |> printfn "%A"

[<EntryPoint>]
let main argv = 
//  transformDictionaries ()
//  transformJson ()
  Versioned.transform ()

  0