TypeShape & Thoth.Json.Net

gistfile1.fs

// Learn more about F# at http://fsharp.org


open Thoth.Json.Net
open TypeShape.Core.Core
open FSharp.Reflection
open Groot.Contracts.SportRadar.Types.Soccer
open System

let apply (d1:Decoder<'C -> 'B>) (d2:Decoder<'C>) : Decoder<'B> =
    Decode.andThen(fun x ->
        Decode.map (fun f ->
            f x) d1 ) d2
    
let applAsObject (d1:Decoder<'C -> 'C>) (d2:Decoder<'C>) (grp:Decode.IGetters) fldName : Decoder<'C> =
    Decode.map ( fun obj ->
       let f =  grp.Required.Field fldName d1
       f obj ) d2 


let rec mkDecoder<'T>() : Decoder<'T> =
    let wrap(t:Decoder<'a>) = unbox<Decoder<'T>> t
    
    let delay (f : unit -> 'T) : Decoder<'T> =
         f () |> Decode.succeed 
    
    let mkMemberDecoder (shape:IShapeMember<'DeclaringType>) =
        let memberVisitor =
            { new IMemberVisitor<'DeclaringType ,Decoder<'DeclaringType -> 'DeclaringType>> with
                      member __.Visit<'Field>(shape: ShapeMember<'DeclaringType,'Field>)  =
                          let md:Decoder<'Field> = mkDecoder<'Field> ()
                          md |> Decode.map(fun f dt ->
                              shape.Set dt f ) }
        shape.Accept( memberVisitor )

    match shapeof<'T> with
    | Shape.Bool ->  Decode.bool |> wrap 
    | Shape.Int32 -> Decode.int |> wrap 
    | Shape.Int64 -> wrap Decode.int64
    | Shape.String -> Decode.string |>  wrap 
    | Shape.DateTimeOffset -> wrap Decode.datetimeOffset
    | Shape.DateTime -> wrap Decode.datetime
    | Shape.Guid ->  wrap Decode.guid
    | Shape.Double -> wrap Decode.float
    | Shape.Decimal -> wrap Decode.decimal
    | Shape.TimeSpan -> wrap Decode.timespan
    | Shape.FSharpOption s ->
        s.Element.Accept {
            new ITypeVisitor<Decoder<'T>> with
                member __.Visit<'a> () =
                    let tp = mkDecoder<'a>()
                    wrap <| Decode.option tp
        }

    | Shape.FSharpList s ->
        s.Element.Accept {
            new ITypeVisitor<Decoder<'T>> with
                member __.Visit<'a> () =
                    let tp = mkDecoder<'a>()
                    wrap <| Decode.list tp
        }

    | Shape.Array s when s.Rank = 1 ->
        s.Element.Accept {
            new ITypeVisitor<Decoder<'T>> with
                member __.Visit<'a> () =
                    let tp = mkDecoder<'a> ()
                    Decode.array tp |> wrap 
        }
    | Shape.FSharpRecord (:? ShapeFSharpRecord<'T> as shape) ->
        
        let toSnakeCase (s:string) =
            s.ToCharArray()
            |> Array.fold (fun s c -> match s, System.Char.IsUpper c with
                                      | "", true -> (System.Char.ToLower c).ToString()
                                      | s, true -> sprintf "%s_%O" s (System.Char.ToLower c)
                                      | _ -> sprintf "%s%O" s c ) ""
        let isOpt (mmbr:IShapeMember<'T>) =
               let typ = mmbr.Member.Type
               typ.IsGenericType && typ.GetGenericTypeDefinition() = typedefof<Option<_>>
        let isArr (mmbr:IShapeMember<'T>) =
            mmbr.Member.Type.IsArray
        
        let folder (g:Decode.IGetters) (i,s) (mmbr, func) =
            printfn "%d, state: %A" i s
            if isOpt mmbr then
              match g.Optional.Field (toSnakeCase mmbr.Label) func with
              | Some f ->  i+1, f s
              | None -> i+1, s 
            else if isArr mmbr then
              match g.Optional.Field (toSnakeCase mmbr.Label) func with
              | Some f ->
                 i+1, f s  
              | None ->
                 let flds = FSharpValue.GetRecordFields(s)
                 flds.[i] <- (Array.CreateInstance(mmbr.Member.Type.GetElementType(), 0) :> obj)
                 i+1, FSharpValue.MakeRecord(s.GetType(), flds) :?> 'T
                 
            else
              i+1, (g.Required.Field (toSnakeCase mmbr.Label) func) s
            
        let dkdr =
            Decode.object
              <| fun g ->
                   let (i,s) =
                      shape.Fields
                      |> Array.map (fun x  -> x, mkMemberDecoder x)
                      |> Array.fold (folder g) (0,shape.CreateUninitialized())
                   s

        dkdr |> wrap 
    |  Shape.Enum s ->
        s.Accept({ new IEnumVisitor<Decoder<'T>> with
                     member __.Visit<'Enum, 'Underlying when 'Enum : enum<'Underlying>
                                       and 'Enum : struct
                                       and 'Enum :> System.ValueType
                                       and 'Enum : (new : unit -> 'Enum)> () =
                        let t = typeof<'Enum>
                        let parse (x:string) = System.Enum.Parse(t, x.ToLower(), ignoreCase = true ) :?> 'Enum
                        Decode.map parse Decode.string |> wrap })
        
    |  Shape.FSharpUnion (:? ShapeFSharpUnion<'T> as shape) ->
        let lngth = shape.UnionCases.Length
        let hasArityGreaterThan n = shape.UnionCases |> Array.exists (fun x -> x.Arity > n )
        let hasArity n = shape.UnionCases |> Array.exists (fun x -> x.Arity = n )
        if lngth > 1 || hasArityGreaterThan 1 || hasArity 0 then
            failwith "only Single Case Unions are welcome f.e. type SingleCase = SimgleCase of type"
        else
            let mkUnionCaseDecoder (case: ShapeFSharpUnionCase<'T>) =
                let field =
                 case.Fields |> Array.head
                |> mkMemberDecoder
                let init = delay case.CreateUninitialized
                apply field init
            let singleCaseUnionDecoder  = shape.UnionCases |> Array.head |> mkUnionCaseDecoder
            singleCaseUnionDecoder
            |> wrap
            
    | _ -> failwithf "unsupported type '%O'" typeof<'T>
      




let str =
    """[{ n : "wtf", as: ["lol", "what?"] }] """

type M1 = {
    Lol : int option
    N : string
    S : int array
    As : string array 
}

[<EntryPoint>]
let main argv =
    let d =  mkDecoder<M1 array> ()
    let s = Decode.fromString d  
    
    match s str with
    | Ok s -> sprintf "it's ok: %A" s 
    | Error e -> sprintf "wtf! %A" e
    |> printfn "%s"
    0 // return an integer exit code