Json type generator

Program.fs

open Newtonsoft.Json
open Newtonsoft.Json.Linq
open System.Collections.Generic
open System
open System.IO
open System.Text

type TypeNodeMut =
  { fieldname: string
    children : Dictionary<string, TypeNodeMut>
    typeDescs: HashSet<TypeDesc> }
  static member Empty() =
    { fieldname = ""
      children = Dictionary<string, TypeNodeMut>()
      typeDescs = HashSet<TypeDesc>() }
and TypeNode =
  { fieldname: string
    children : Map<string, TypeNode>
    typeDescs: string list
    revPath: string list }
and TypeDesc = 
  | Plain of Type
  | StringDateTime

let shortTypeName (typ:Type) = 
  if typ.Namespace = "System" then
    match typ.Name with
    | "Int64" -> "int64"
    | "String" -> "string"
    | "Boolean" -> "bool"
    | s -> s
  else typ.FullName

let immTypeNodeOfMut (node:TypeNodeMut) : TypeNode =
  let rec impl (node:TypeNodeMut) (revPath:string list) =
    let children = 
      seq {
        for (KeyValue(k, v)) in node.children do
          yield k, impl v (k::revPath)
      } |> Map.ofSeq

    let typeDescs = 
      node.typeDescs
      |> Seq.map (function
                  | TypeDesc.Plain(typ) ->
                    shortTypeName typ
                  | TypeDesc.StringDateTime -> 
                    "DateTime")
      |> List.ofSeq

    { TypeNode.fieldname = node.fieldname
      TypeNode.children = children
      TypeNode.typeDescs = typeDescs
      TypeNode.revPath = revPath }
  impl node [(node.fieldname)]

type IDictionary<'k,'v> with
  member this.GetOrCreate(k:'k, ctor: unit -> 'v) =
    let ok, n = this.TryGetValue(k)
    if ok then n
    else
      let n = ctor()
      this.[k] <- n
      n 

let dateTimeParsable (s:string) =
  fst <| DateTime.TryParse(s)

let (|DateTimeParsableM|_|) (o:obj) =
  match o with
  | :? JValue as jv ->
    match jv.Value with
    | :? string as s when dateTimeParsable(s) ->
      Some <| DateTimeParsableM
    | _ -> None
  | _ -> None

let (|JValueM|_|) (o:obj) =
  match o with
  | :? JValue as jv ->
    Some <| JValueM((jv.Value))
  | _ -> None

let rec addTypes (node:TypeNodeMut) (k:string) (v:obj) =
  let cnode = 
    node.children.GetOrCreate(
      k, 
      (fun () -> { TypeNodeMut.Empty() with fieldname = k }))  
  match v with
  | :? JObject as o ->
    for (KeyValue(childK, childV)) in o do
      addTypes cnode childK childV |> ignore
  | :? JArray as xs ->
    for x in xs do
      addTypes cnode "[0]" x |> ignore
  | DateTimeParsableM -> 
    cnode.typeDescs.Add(TypeDesc.StringDateTime) |> ignore
  | JValueM(x) ->
    ignore <| cnode.typeDescs.Add((TypeDesc.Plain(x.GetType())))
  | x ->
    ignore <| cnode.typeDescs.Add((TypeDesc.Plain(x.GetType())))
  node

let walkTypeTree (node:TypeNode) =
  let rec loop (node:TypeNode) =
    seq {
      if not node.children.IsEmpty then
        yield node
        for (KeyValue(k,v)) in node.children do
          yield! loop v
    }
  let nodes = loop node
  let collMembers, baseTypes = 
    nodes 
    |> Array.ofSeq 
    |> Array.partition (fun ps -> ps.revPath.Head = "[0]")

  seq {
    yield! baseTypes
    yield! collMembers
  }

type TypeRenderCtx =
  { nameAssignments : Dictionary<string list, string>
    namesTaken : HashSet<string>
    nodeByPath : Dictionary<string list, TypeNode> }
  static member Fresh() =
    { nameAssignments = Dictionary<_,_>(50)
      namesTaken = HashSet<string>()
      nodeByPath = Dictionary<_,_>(50) }
  member this.Add (revPath: string list) (name: string) (node:TypeNode) =
    this.nameAssignments.Add(revPath, name)
    this.namesTaken.Add(name) |> ignore
    this.nodeByPath.Add(revPath, node)

open System.Data.Entity.Design.PluralizationServices

let singularize =
  let culture = System.Globalization.CultureInfo.CurrentCulture
  let plurService = PluralizationService.CreateService(culture)
  plurService.Singularize

let getName (ctx:TypeRenderCtx) node =
  let revPath = node.revPath
  if ctx.nameAssignments.ContainsKey(revPath) then
    ctx.nameAssignments.[revPath]
  else
    match revPath with
    | "[0]"::ps ->
      let baseName = ctx.nameAssignments.[ps]
      let name = baseName + "[]"
      ctx.Add revPath name node
      name
    | p::ps ->
      let cand = singularize p

      if not <| ctx.namesTaken.Contains(cand) then
        ctx.Add revPath cand node
        cand
      else
        let rec findName ctx ps start =
          match ps with
          | [] ->
            seq {
              for i in 2..9999 do
                let cand = start + "_" + i.ToString()
                if not <| ctx.namesTaken.Contains(cand) then
                  ctx.Add revPath cand node
                  yield cand
            } |> Seq.head
          | p::ps ->
            let cand = p + "_" + start
            if ctx.namesTaken.Contains(cand) then
              findName ctx ps cand
            else
              ctx.Add revPath cand node
              cand
        let ps = List.filter (fun p -> p <> "[0]") ps
        findName ctx ps cand
    | _ -> failwith "logic error"

type FsRecord =
  { typeName: string; fields: FsRecordField list }
and FsRecordField = 
  { name: string; typeName: string }

let mkRecords (ctx:TypeRenderCtx) (root:TypeNode) =
  let q = Queue()
  let recs = ResizeArray<_>()
  q.Enqueue(root)
  let fields = ResizeArray<FsRecordField>()

  while q.Count > 0 do
    let node = q.Dequeue()
    let name = 
      match node.revPath with
      | "[0]"::ps ->
        ctx.nameAssignments.[ps]
      | ps -> 
        ctx.nameAssignments.[ps]

    for (KeyValue(fieldName, cnode)) in node.children do
      match cnode.children.Count with
      | 0 ->
        // Literal field
        fields.Add({name = fieldName; typeName = cnode.typeDescs.Head})
      | 1 when cnode.children.ContainsKey("[0]") ->
        // Array field
        let ok, name = ctx.nameAssignments.TryGetValue(("[0]" :: cnode.revPath))
        if ok then
          let n = ctx.nodeByPath.[("[0]" :: cnode.revPath)]
          q.Enqueue(n)
          fields.Add({name = fieldName; typeName = name})
      | _ -> 
        // Object
        q.Enqueue(cnode)
        let name = ctx.nameAssignments.[(cnode.revPath)]
        fields.Add({name = fieldName; typeName = name})
    let r = 
      { typeName = name
        fields = fields |> List.ofSeq }
    fields.Clear()
    recs.Add(r)
  recs |> Array.ofSeq

let renderRecords (recDefs: FsRecord[]) =
  let sb = new StringBuilder()

  for i = 0 to recDefs.Length - 1 do
    let defs = if i = 0 then "type" else "and"
    let recDef = recDefs.[i]
    match recDef.fields with
    | [] -> failwith "logic error"
    | [field] -> 
      sb.Append(sprintf "%s %s =\n  { %s : %s }\n" defs recDef.typeName field.name field.typeName) |> ignore
    | field::fields ->
      let _ = sb.Append(sprintf "%s %s =\n  { " defs recDef.typeName)
      let _ = sb.Append(sprintf "%s: %s" field.name field.typeName)
      let len = fields.Length
      fields |> Seq.iteri (fun i field ->
        let sfx = if i = len - 1 then " }\n" else ""
        let s = sprintf "\n    %s: %s%s" field.name field.typeName sfx
        sb.Append(s) |> ignore)
  sb.ToString()

let outputTypesStr (o:Dictionary<string, obj>) =
  let root = 
    { TypeNodeMut.Empty() with fieldname = "MyRoot"}

  let typeTree = 
    Seq.fold 
      (fun acc (KeyValue(k,v)) -> 
        addTypes acc k v)
      root
      o
  let typeTree = immTypeNodeOfMut typeTree
  let ctx = TypeRenderCtx.Fresh()
  for node in walkTypeTree typeTree do
    let name = getName ctx node
    ()
  let recs = mkRecords ctx typeTree

  printf "%s" (renderRecords recs)
  ""

[<EntryPoint>]
let main argv = 
  let jsonStr = File.ReadAllText(@"C:/Users/Isak/Desktop/resp.json")
  let o = JsonConvert.DeserializeObject<Dictionary<string, obj>>(jsonStr)
  printfn "%s" (outputTypesStr o)
  Console.ReadLine() |> ignore
  0 // return an integer exit code